diff options
| author | upstream source tree <ports@midipix.org> | 2015-03-15 20:14:05 -0400 |
|---|---|---|
| committer | upstream source tree <ports@midipix.org> | 2015-03-15 20:14:05 -0400 |
| commit | 554fd8c5195424bdbcabf5de30fdc183aba391bd (patch) | |
| tree | 976dc5ab7fddf506dadce60ae936f43f58787092 /gcc/testsuite/ada/acats/tests/c8 | |
| download | cbb-gcc-4.6.4-554fd8c5195424bdbcabf5de30fdc183aba391bd.tar.bz2 cbb-gcc-4.6.4-554fd8c5195424bdbcabf5de30fdc183aba391bd.tar.xz | |
obtained gcc-4.6.4.tar.bz2 from upstream website;upstream
verified gcc-4.6.4.tar.bz2.sig;
imported gcc-4.6.4 source tree from verified upstream tarball.
downloading a git-generated archive based on the 'upstream' tag
should provide you with a source tree that is binary identical
to the one extracted from the above tarball.
if you have obtained the source via the command 'git clone',
however, do note that line-endings of files in your working
directory might differ from line-endings of the respective
files in the upstream repository.
Diffstat (limited to 'gcc/testsuite/ada/acats/tests/c8')
153 files changed, 21763 insertions, 0 deletions
diff --git a/gcc/testsuite/ada/acats/tests/c8/c83007a.ada b/gcc/testsuite/ada/acats/tests/c8/c83007a.ada new file mode 100644 index 000000000..f33d907af --- /dev/null +++ b/gcc/testsuite/ada/acats/tests/c8/c83007a.ada @@ -0,0 +1,95 @@ +-- C83007A.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 A FORMAL PARAMETER OF A SUBPROGRAM DECLARED BY A +-- RENAMING DECLARATION CAN HAVE THE SAME IDENTIFIER AS A +-- DECLARATION IN THE BODY OF THE RENAMED SUBPROGRAM. + +-- HISTORY: +-- VCL 02/18/88 CREATED ORIGINAL TEST. + + +WITH REPORT; USE REPORT; +PROCEDURE C83007A IS +BEGIN + TEST ("C83007A", "A FORMAL PARAMETER OF A SUBPROGRAM DECLARED " & + "BY A RENAMING DECLARATION CAN HAVE THE SAME " & + "IDENTIFIER AS A DECLARATION IN THE BODY OF " & + "THE RENAMED SUBPROGRAM"); + DECLARE + PROCEDURE P (ONE : INTEGER; TWO : FLOAT; THREE : STRING); + + PROCEDURE R (D1 : INTEGER; + D2 : FLOAT; + D3 : STRING) RENAMES P; + + PROCEDURE P (ONE : INTEGER; TWO : FLOAT; THREE : STRING) IS + TYPE D1 IS RANGE 1..10; + I : D1 := D1(IDENT_INT (7)); + + D2 : FLOAT; + + FUNCTION D3 RETURN STRING IS + BEGIN + RETURN "D3"; + END D3; + + FUNCTION IDENT_FLOAT (VAL : FLOAT) RETURN FLOAT IS + BEGIN + IF EQUAL (3, 3) THEN + RETURN VAL; + ELSE + RETURN 0.0; + END IF; + END IDENT_FLOAT; + + BEGIN + IF ONE /= 5 THEN + FAILED ("INCORRECT VALUE FOR PARAMETER ONE"); + END IF; + IF TWO /= 4.5 THEN + FAILED ("INCORRECT VALUE FOR PARAMETER TWO"); + END IF; + IF THREE /= "R1" THEN + FAILED ("INCORRECT VALUE FOR PARAMETER THREE"); + END IF; + + IF I /= 7 THEN + FAILED ("INCORRECT VALUE FOR OBJECT I"); + END IF; + D2 := IDENT_FLOAT (3.5); + IF D2 /= 3.5 THEN + FAILED ("INCORRECT VALUE FOR OBJECT D2"); + END IF; + IF D3 /= "D3" THEN + FAILED ("INCORRECT VALUE FOR FUNCTION D3"); + END IF; + END P; + BEGIN + R (D1=>5, D2=>4.5, D3=>"R1"); + END; + + RESULT; +END C83007A; diff --git a/gcc/testsuite/ada/acats/tests/c8/c83012d.ada b/gcc/testsuite/ada/acats/tests/c8/c83012d.ada new file mode 100644 index 000000000..a73639c6c --- /dev/null +++ b/gcc/testsuite/ada/acats/tests/c8/c83012d.ada @@ -0,0 +1,116 @@ +-- C83012D.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 WITHIN A GENERIC PACKAGE INSTANTIATION, A DECLARATION +-- HAVING THE SAME IDENTIFIER AS THE PACKAGE IS VISIBLE BY +-- SELECTION. + +-- HISTORY: +-- JET 08/11/88 CREATED ORIGINAL TEST. + +WITH REPORT; USE REPORT; +PROCEDURE C83012D IS + + PACKAGE PACK IS + SUBTYPE PACK1 IS INTEGER; + PACK2 : INTEGER := 2; + END PACK; + + TYPE REC IS RECORD + PACK3 : INTEGER; + PACK4 : INTEGER; + END RECORD; + + R : REC := (PACK3 => 3, PACK4 => 1); + + GENERIC + TYPE T IS RANGE <>; + PACKAGE GEN1 IS + J : INTEGER := IDENT_INT(1); + END GEN1; + + GENERIC + I : INTEGER; + PACKAGE GEN2 IS + J : INTEGER := IDENT_INT(I); + END GEN2; + + GENERIC + R : REC; + PACKAGE GEN3 IS + J : INTEGER := IDENT_INT(R.PACK4); + END GEN3; + + GENERIC + PACK6 : INTEGER; + PACKAGE GEN4 IS + J : INTEGER := IDENT_INT(PACK6); + END GEN4; + + FUNCTION FUNC (PACK5: INTEGER) RETURN INTEGER IS + BEGIN + RETURN IDENT_INT(PACK5); + END FUNC; + + PACKAGE PACK1 IS NEW GEN1(PACK.PACK1); + PACKAGE PACK2 IS NEW GEN2(PACK.PACK2); + PACKAGE PACK3 IS NEW GEN2(R.PACK3); + PACKAGE PACK4 IS NEW GEN3((1, PACK4 => 4)); + PACKAGE PACK5 IS NEW GEN2(FUNC(PACK5 => 5)); + PACKAGE PACK6 IS NEW GEN4(PACK6 => 6); + +BEGIN + TEST ("C83012D", "CHECK THAT WITHIN A GENERIC PACKAGE " & + "INSTANTIATION, A DECLARATION HAVING THE SAME " & + "IDENTIFIER AS THE PACKAGE IS VISIBLE BY " & + "SELECTION"); + + IF PACK1.J /= 1 THEN + FAILED ("INCORRECT VALUE OF PACK1.J"); + END IF; + + IF PACK2.J /= 2 THEN + FAILED ("INCORRECT VALUE OF PACK2.J"); + END IF; + + IF PACK3.J /= 3 THEN + FAILED ("INCORRECT VALUE OF PACK3.J"); + END IF; + + IF PACK4.J /= 4 THEN + FAILED ("INCORRECT VALUE OF PACK4.J"); + END IF; + + IF PACK5.J /= 5 THEN + FAILED ("INCORRECT VALUE OF PACK5.J"); + END IF; + + IF PACK6.J /= 6 THEN + FAILED ("INCORRECT VALUE OF PACK6.J"); + END IF; + + RESULT; + +END C83012D; diff --git a/gcc/testsuite/ada/acats/tests/c8/c83022a.ada b/gcc/testsuite/ada/acats/tests/c8/c83022a.ada new file mode 100644 index 000000000..391c9dda5 --- /dev/null +++ b/gcc/testsuite/ada/acats/tests/c8/c83022a.ada @@ -0,0 +1,338 @@ +-- C83022A.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 A DECLARATION IN A SUBPROGRAM FORMAL PART OR BODY +-- HIDES AN OUTER DECLARATION OF A HOMOGRAPH. ALSO CHECK THAT THE +-- OUTER DECLARATION IS DIRECTLY VISIBLE IN BOTH DECLARATIVE +-- REGIONS BEFORE THE DECLARATION OF THE INNER HOMOGRAPH AND THE +-- OUTER DECLARATION IS VISIBLE BY SELECTION AFTER THE INNER +-- HOMOGRAH DECLARATION. + +-- HISTORY: +-- TBN 08/01/88 CREATED ORIGINAL TEST. + +WITH REPORT; USE REPORT; +PROCEDURE C83022A IS + + GENERIC + TYPE T IS PRIVATE; + X : T; + FUNCTION GEN_FUN RETURN T; + + FUNCTION GEN_FUN RETURN T IS + BEGIN + RETURN X; + END GEN_FUN; + +BEGIN + TEST ("C83022A", "CHECK THAT A DECLARATION IN A SUBPROGRAM " & + "FORMAL PART OR BODY HIDES AN OUTER " & + "DECLARATION OF A HOMOGRAPH"); + + ONE: + DECLARE -- SUBPROGRAM DECLARATIVE REGION. + A : INTEGER := IDENT_INT(2); + B : INTEGER := A; + + PROCEDURE INNER (X : IN OUT INTEGER) IS + C : INTEGER := A; + A : INTEGER := IDENT_INT(3); + BEGIN + IF A /= IDENT_INT(3) THEN + FAILED ("INCORRECT VALUE FOR INNER HOMOGRAPH - 1"); + END IF; + IF ONE.A /= IDENT_INT(2) THEN + FAILED ("INCORRECT VALUE FOR OUTER HOMOGRAPH - 2"); + END IF; + IF ONE.B /= IDENT_INT(2) THEN + FAILED ("INCORRECT VALUE FOR OUTER VARIABLE - 3"); + END IF; + IF C /= IDENT_INT(2) THEN + FAILED ("INCORRECT VALUE FOR INNER VARIABLE - 4"); + END IF; + IF X /= IDENT_INT(2) THEN + FAILED ("INCORRECT VALUE PASSED IN - 5"); + END IF; + IF EQUAL(1,1) THEN + X := A; + ELSE + X := ONE.A; + END IF; + END INNER; + + BEGIN -- ONE + INNER (A); + IF A /= IDENT_INT(3) THEN + FAILED ("INCORRECT VALUE PASSED OUT - 6"); + END IF; + END ONE; + + TWO: + DECLARE -- FORMAL PARAMETER OF SUBPROGRAM. + A : INTEGER := IDENT_INT(2); + B : INTEGER := A; + OBJ : INTEGER := IDENT_INT(3); + + PROCEDURE INNER (X : IN INTEGER := A; + A : IN OUT INTEGER) IS + C : INTEGER := A; + BEGIN + IF A /= IDENT_INT(3) THEN + FAILED ("INCORRECT VALUE FOR INNER HOMOGRAPH -10"); + END IF; + IF TWO.A /= IDENT_INT(2) THEN + FAILED ("INCORRECT VALUE FOR OUTER HOMOGRAPH - 11"); + END IF; + IF TWO.B /= IDENT_INT(2) THEN + FAILED ("INCORRECT VALUE FOR OUTER VARIABLE - 12"); + END IF; + IF C /= IDENT_INT(3) THEN + FAILED ("INCORRECT VALUE FOR INNER VARIABLE - 13"); + END IF; + IF X /= IDENT_INT(2) THEN + FAILED ("INCORRECT VALUE PASSED IN - 14"); + END IF; + IF EQUAL(1,1) THEN + A := IDENT_INT(4); + ELSE + A := 1; + END IF; + END INNER; + + BEGIN -- TWO + INNER (A => OBJ); + IF OBJ /= IDENT_INT(4) THEN + FAILED ("INCORRECT VALUE PASSED OUT - 15"); + END IF; + END TWO; + + THREE: + DECLARE -- AFTER THE SPECIFICATION OF SUBPROGRAM. + A : INTEGER := IDENT_INT(2); + + FUNCTION INNER (X : INTEGER) RETURN INTEGER; + + B : INTEGER := A; + + FUNCTION INNER (X : INTEGER) RETURN INTEGER IS + C : INTEGER := A; + A : INTEGER := IDENT_INT(3); + BEGIN + IF A /= IDENT_INT(3) THEN + FAILED ("INCORRECT VALUE FOR INNER HOMOGRAPH - 20"); + END IF; + IF THREE.A /= IDENT_INT(2) THEN + FAILED ("INCORRECT VALUE FOR OUTER HOMOGRAPH - 21"); + END IF; + IF THREE.B /= IDENT_INT(2) THEN + FAILED ("INCORRECT VALUE FOR OUTER VARIABLE - 22"); + END IF; + IF C /= IDENT_INT(2) THEN + FAILED ("INCORRECT VALUE FOR INNER VARIABLE - 23"); + END IF; + IF X /= IDENT_INT(2) THEN + FAILED ("INCORRECT VALUE PASSED IN - 24"); + END IF; + IF EQUAL(1,1) THEN + RETURN A; + ELSE + RETURN X; + END IF; + END INNER; + + BEGIN -- THREE + IF INNER(A) /= IDENT_INT(3) THEN + FAILED ("INCORRECT VALUE PASSED OUT - 25"); + END IF; + END THREE; + + FOUR: + DECLARE -- RENAMING DECLARATION. + A : INTEGER := IDENT_INT(2); + + PROCEDURE TEMPLATE (X : IN INTEGER := A; + Y : IN OUT INTEGER); + + PROCEDURE INNER (Z : IN INTEGER := A; + A : IN OUT INTEGER) RENAMES TEMPLATE; + + B : INTEGER := A; + OBJ : INTEGER := 5; + + PROCEDURE TEMPLATE (X : IN INTEGER := A; + Y : IN OUT INTEGER) IS + BEGIN -- TEMPLATE + IF X /= IDENT_INT(2) THEN + FAILED ("INCORRECT RESULTS FOR VARIABLE - 30"); + END IF; + IF Y /= IDENT_INT(5) THEN + FAILED ("INCORRECT RESULTS FOR VARIABLE - 31"); + END IF; + Y := IDENT_INT(2 * X); + IF FOUR.A /= IDENT_INT(2) THEN + FAILED ("INCORRECT RESULTS FOR OUTER HOMOGRAPH - " & + "32"); + END IF; + END TEMPLATE; + + BEGIN -- FOUR + IF B /= IDENT_INT(2) THEN + FAILED ("INCORRECT VALUE FOR OUTER VARIABLE - 32"); + END IF; + INNER (A => OBJ); + IF OBJ /= IDENT_INT(4) THEN + FAILED ("INCORRECT VALUE PASSED OUT - 33"); + END IF; + END FOUR; + + FIVE: + DECLARE -- GENERIC FORMAL SUBPROGRAM. + A : INTEGER := IDENT_INT(2); + B : INTEGER := A; + + PROCEDURE INNER (X : IN OUT INTEGER); + + GENERIC + WITH PROCEDURE SUBPR (Y : IN OUT INTEGER) IS <>; + PACKAGE P IS + PAC_VAR : INTEGER := 1; + END P; + + PROCEDURE INNER (X : IN OUT INTEGER) IS + C : INTEGER := A; + A : INTEGER := IDENT_INT(3); + BEGIN + IF A /= IDENT_INT(3) THEN + FAILED ("INCORRECT VALUE FOR INNER HOMOGRAPH - 41"); + END IF; + IF FIVE.A /= IDENT_INT(2) THEN + FAILED ("INCORRECT VALUE FOR OUTER HOMOGRAPH - 42"); + END IF; + IF FIVE.B /= IDENT_INT(2) THEN + FAILED ("INCORRECT VALUE FOR OUTER VARIABLE - 43"); + END IF; + IF C /= IDENT_INT(2) THEN + FAILED ("INCORRECT VALUE FOR INNER VARIABLE - 44"); + END IF; + IF X /= IDENT_INT(2) THEN + FAILED ("INCORRECT VALUE PASSED IN - 45"); + END IF; + IF EQUAL(1,1) THEN + X := A; + ELSE + X := FIVE.A; + END IF; + END INNER; + + PACKAGE BODY P IS + BEGIN + SUBPR (A); + IF A /= IDENT_INT(3) THEN + FAILED ("INCORRECT VALUE PASSED OUT - 46"); + END IF; + IF PAC_VAR /= IDENT_INT(1) THEN + FAILED ("INCORRECT VALUE FOR PAC_VAR - 47"); + END IF; + END P; + + PACKAGE NEW_P IS NEW P (INNER); + + BEGIN -- FIVE + NULL; + END FIVE; + + SIX: + DECLARE -- GENERIC INSTANTIATION. + A : INTEGER := IDENT_INT(2); + B : INTEGER := A; + OBJ : INTEGER := IDENT_INT(3); + + GENERIC + PROCEDURE INNER (X : IN INTEGER := A; + A : IN OUT INTEGER); + + PROCEDURE INNER (X : IN INTEGER := SIX.A; + A : IN OUT INTEGER) IS + C : INTEGER := A; + BEGIN + IF A /= IDENT_INT(3) THEN + FAILED ("INCORRECT VALUE FOR INNER HOMOGRAPH -50"); + END IF; + IF SIX.A /= IDENT_INT(2) THEN + FAILED ("INCORRECT VALUE FOR OUTER HOMOGRAPH - 51"); + END IF; + IF SIX.B /= IDENT_INT(2) THEN + FAILED ("INCORRECT VALUE FOR OUTER VARIABLE - 52"); + END IF; + IF C /= IDENT_INT(3) THEN + FAILED ("INCORRECT VALUE FOR INNER VARIABLE - 53"); + END IF; + IF X /= IDENT_INT(2) THEN + FAILED ("INCORRECT VALUE PASSED IN - 54"); + END IF; + IF EQUAL(1,1) THEN + A := IDENT_INT(4); + ELSE + A := 1; + END IF; + END INNER; + + PROCEDURE SUBPR IS NEW INNER; + + BEGIN -- SIX + SUBPR (A => OBJ); + IF OBJ /= IDENT_INT(4) THEN + FAILED ("INCORRECT VALUE PASSED OUT - 55"); + END IF; + END SIX; + + SEVEN: + DECLARE -- OVERLOADING OF FUNCTIONS. + + OBJ : INTEGER := 1; + FLO : FLOAT := 5.0; + + FUNCTION F IS NEW GEN_FUN (INTEGER, OBJ); + + PROCEDURE INNER (X : IN OUT INTEGER; F : IN FLOAT); + + FUNCTION F IS NEW GEN_FUN (FLOAT, FLO); + + PROCEDURE INNER (X : IN OUT INTEGER; F : IN FLOAT) IS + BEGIN + X := INTEGER(F); + END INNER; + + BEGIN + FLO := 6.25; + INNER (OBJ, FLO); + IF OBJ /= IDENT_INT(6) THEN + FAILED ("INCORRECT VALUE RETURNED FROM FUNCTION - 60"); + END IF; + END SEVEN; + + + RESULT; +END C83022A; diff --git a/gcc/testsuite/ada/acats/tests/c8/c83022g0.ada b/gcc/testsuite/ada/acats/tests/c8/c83022g0.ada new file mode 100644 index 000000000..36f3f9065 --- /dev/null +++ b/gcc/testsuite/ada/acats/tests/c8/c83022g0.ada @@ -0,0 +1,165 @@ +-- C83022G0M.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 A DECLARATION IN A SUBPROGRAM FORMAL PART OR BODY +-- HIDES AN OUTER DECLARATION OF A HOMOGRAPH. ALSO CHECK THAT THE +-- OUTER DECLARATION IS DIRECTLY VISIBLE IN BOTH DECLARATIVE +-- REGIONS BEFORE THE DECLARATION OF THE INNER HOMOGRAPH AND THE +-- OUTER DECLARATION IS VISIBLE BY SELECTION AFTER THE INNER +-- HOMOGRAPH DECLARATION, IF THE SUBPROGRAM BODY IS COMPILED +-- SEPARATELY AS A SUBUNIT. + +-- SEPARATE FILES ARE: +-- C83022G0M.ADA - (THIS FILE) MAIN PROGRAM. +-- C83022G1.ADA -- SUBPROGRAM BODIES. + +-- HISTORY: +-- BCB 08/26/88 CREATED ORIGINAL TEST. + +WITH REPORT; USE REPORT; + +PROCEDURE C83022G0M IS + + GENERIC + TYPE T IS PRIVATE; + X : T; + FUNCTION GEN_FUN RETURN T; + + A : INTEGER := IDENT_INT(2); + B : INTEGER := A; + + OBJ : INTEGER := IDENT_INT(3); + + FLO : FLOAT := 5.0; + + PROCEDURE TEMPLATE (X : IN INTEGER := A; + Y : IN OUT INTEGER); + + PROCEDURE INNER4 (Z : IN INTEGER := A; + A : IN OUT INTEGER) RENAMES TEMPLATE; + + PROCEDURE INNER (X : IN OUT INTEGER) IS SEPARATE; + + PROCEDURE INNER2 (X : IN INTEGER := A; + A : IN OUT INTEGER) IS SEPARATE; + + FUNCTION INNER3 (X : INTEGER) RETURN INTEGER IS SEPARATE; + + PROCEDURE TEMPLATE (X : IN INTEGER := A; + Y : IN OUT INTEGER) IS SEPARATE; + + PROCEDURE INNER5 (X : IN OUT INTEGER) IS SEPARATE; + + GENERIC + WITH PROCEDURE SUBPR (Y : IN OUT INTEGER) IS <>; + PACKAGE P IS + PAC_VAR : INTEGER := 1; + END P; + + PACKAGE BODY P IS + BEGIN + SUBPR (A); + + IF A /= IDENT_INT(3) THEN + FAILED ("INCORRECT VALUE PASSED OUT - 1"); + END IF; + + IF PAC_VAR /= IDENT_INT(1) THEN + FAILED ("INCORRECT VALUE FOR PAC_VAR - 2"); + END IF; + END P; + + PACKAGE NEW_P IS NEW P (INNER5); + + FUNCTION GEN_FUN RETURN T IS + BEGIN + RETURN X; + END GEN_FUN; + + FUNCTION F IS NEW GEN_FUN (INTEGER, OBJ); + + PROCEDURE INNER6 (X : IN OUT INTEGER; F : IN FLOAT); + + FUNCTION F IS NEW GEN_FUN (FLOAT, FLO); + + PROCEDURE INNER6 (X : IN OUT INTEGER; F : IN FLOAT) IS SEPARATE; + +BEGIN + TEST ("C83022G", "CHECK THAT A DECLARATION IN A SUBPROGRAM " & + "FORMAL PART OR BODY HIDES AN OUTER " & + "DECLARATION OF A HOMOGRAPH"); + + A := IDENT_INT(2); + B := A; + + INNER (A); + + IF A /= IDENT_INT(3) THEN + FAILED ("INCORRECT VALUE PASSED OUT - 3"); + END IF; + + A := IDENT_INT(2); + + INNER2 (A => OBJ); + + IF OBJ /= IDENT_INT(4) THEN + FAILED ("INCORRECT VALUE PASSED OUT - 4"); + END IF; + + A := IDENT_INT(2); + + B := A; + + IF INNER3(A) /= IDENT_INT(3) THEN + FAILED ("INCORRECT VALUE PASSED OUT - 5"); + END IF; + + A := IDENT_INT(2); + + B := A; + OBJ := 5; + + IF B /= IDENT_INT(2) THEN + FAILED ("INCORRECT VALUE FOR OUTER VARIABLE - 6"); + END IF; + + INNER4 (A => OBJ); + + IF OBJ /= IDENT_INT(4) THEN + FAILED ("INCORRECT VALUE PASSED OUT - 7"); + END IF; + + OBJ := 1; + + FLO := 6.25; + + INNER6 (OBJ, FLO); + + IF OBJ /= IDENT_INT(6) THEN + FAILED ("INCORRECT VALUE RETURNED FROM FUNCTION - 8"); + END IF; + + RESULT; +END C83022G0M; diff --git a/gcc/testsuite/ada/acats/tests/c8/c83022g1.ada b/gcc/testsuite/ada/acats/tests/c8/c83022g1.ada new file mode 100644 index 000000000..e25bdc982 --- /dev/null +++ b/gcc/testsuite/ada/acats/tests/c8/c83022g1.ada @@ -0,0 +1,189 @@ +-- C83022G1.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 A DECLARATION IN A SUBPROGRAM FORMAL PART OR BODY +-- HIDES AN OUTER DECLARATION OF A HOMOGRAPH. ALSO CHECK THAT THE +-- OUTER DECLARATION IS DIRECTLY VISIBLE IN BOTH DECLARATIVE +-- REGIONS BEFORE THE DECLARATION OF THE INNER HOMOGRAPH AND THE +-- OUTER DECLARATION IS VISIBLE BY SELECTION AFTER THE INNER +-- HOMOGRAPH DECLARATION, IF THE SUBPROGRAM BODY IS COMPILED +-- SEPARATELY AS A SUBUNIT. + +-- HISTORY: +-- BCB 08/26/88 CREATED ORIGINAL TEST. + +SEPARATE (C83022G0M) +PROCEDURE INNER (X : IN OUT INTEGER) IS + C : INTEGER := A; + A : INTEGER := IDENT_INT(3); +BEGIN + IF A /= IDENT_INT(3) THEN + FAILED ("INCORRECT VALUE FOR INNER HOMOGRAPH - 1"); + END IF; + + IF C83022G0M.A /= IDENT_INT(2) THEN + FAILED ("INCORRECT VALUE FOR OUTER HOMOGRAPH - 2"); + END IF; + + IF C83022G0M.B /= IDENT_INT(2) THEN + FAILED ("INCORRECT VALUE FOR OUTER VARIABLE - 3"); + END IF; + + IF C /= IDENT_INT(2) THEN + FAILED ("INCORRECT VALUE FOR INNER VARIABLE - 4"); + END IF; + + IF X /= IDENT_INT(2) THEN + FAILED ("INCORRECT VALUE PASSED IN - 5"); + END IF; + + IF EQUAL(1,1) THEN + X := A; + ELSE + X := C83022G0M.A; + END IF; +END INNER; + +SEPARATE (C83022G0M) +PROCEDURE INNER2 (X : IN INTEGER := C83022G0M.A; + A : IN OUT INTEGER) IS + C : INTEGER := A; +BEGIN + IF A /= IDENT_INT(3) THEN + FAILED ("INCORRECT VALUE FOR INNER HOMOGRAPH -10"); + END IF; + + IF C83022G0M.A /= IDENT_INT(2) THEN + FAILED ("INCORRECT VALUE FOR OUTER HOMOGRAPH - 11"); + END IF; + + IF C83022G0M.B /= IDENT_INT(2) THEN + FAILED ("INCORRECT VALUE FOR OUTER VARIABLE - 12"); + END IF; + + IF C /= IDENT_INT(3) THEN + FAILED ("INCORRECT VALUE FOR INNER VARIABLE - 13"); + END IF; + + IF X /= IDENT_INT(2) THEN + FAILED ("INCORRECT VALUE PASSED IN - 14"); + END IF; + + IF EQUAL(1,1) THEN + A := IDENT_INT(4); + ELSE + A := 1; + END IF; +END INNER2; + +SEPARATE (C83022G0M) +FUNCTION INNER3 (X : INTEGER) RETURN INTEGER IS + C : INTEGER := A; + A : INTEGER := IDENT_INT(3); +BEGIN + IF A /= IDENT_INT(3) THEN + FAILED ("INCORRECT VALUE FOR INNER HOMOGRAPH - 20"); + END IF; + + IF C83022G0M.A /= IDENT_INT(2) THEN + FAILED ("INCORRECT VALUE FOR OUTER HOMOGRAPH - 21"); + END IF; + + IF C83022G0M.B /= IDENT_INT(2) THEN + FAILED ("INCORRECT VALUE FOR OUTER VARIABLE - 22"); + END IF; + + IF C /= IDENT_INT(2) THEN + FAILED ("INCORRECT VALUE FOR INNER VARIABLE - 23"); + END IF; + + IF X /= IDENT_INT(2) THEN + FAILED ("INCORRECT VALUE PASSED IN - 24"); + END IF; + + IF EQUAL(1,1) THEN + RETURN A; + ELSE + RETURN X; + END IF; +END INNER3; + +SEPARATE (C83022G0M) +PROCEDURE TEMPLATE (X : IN INTEGER := A; + Y : IN OUT INTEGER) IS +BEGIN -- TEMPLATE + IF X /= IDENT_INT(2) THEN + FAILED ("INCORRECT RESULTS FOR VARIABLE - 30"); + END IF; + + IF Y /= IDENT_INT(5) THEN + FAILED ("INCORRECT RESULTS FOR VARIABLE - 31"); + END IF; + + Y := IDENT_INT(2 * X); + + IF C83022G0M.A /= IDENT_INT(2) THEN + FAILED ("INCORRECT RESULTS FOR OUTER HOMOGRAPH - " & + "32"); + END IF; +END TEMPLATE; + +SEPARATE (C83022G0M) +PROCEDURE INNER5 (X : IN OUT INTEGER) IS + C : INTEGER := A; + A : INTEGER := IDENT_INT(3); +BEGIN + IF A /= IDENT_INT(3) THEN + FAILED ("INCORRECT VALUE FOR INNER HOMOGRAPH - 41"); + END IF; + + IF C83022G0M.A /= IDENT_INT(2) THEN + FAILED ("INCORRECT VALUE FOR OUTER HOMOGRAPH - 42"); + END IF; + + IF C83022G0M.B /= IDENT_INT(2) THEN + FAILED ("INCORRECT VALUE FOR OUTER VARIABLE - 43"); + END IF; + + IF C /= IDENT_INT(2) THEN + FAILED ("INCORRECT VALUE FOR INNER VARIABLE - 44"); + END IF; + + IF X /= IDENT_INT(2) THEN + FAILED ("INCORRECT VALUE PASSED IN - 45"); + END IF; + + IF EQUAL(1,1) THEN + X := A; + ELSE + X := C83022G0M.A; + END IF; +END INNER5; + +SEPARATE (C83022G0M) +PROCEDURE INNER6 (X : IN OUT INTEGER; F : IN FLOAT) IS +BEGIN + X := INTEGER(F); +END INNER6; diff --git a/gcc/testsuite/ada/acats/tests/c8/c83023a.ada b/gcc/testsuite/ada/acats/tests/c8/c83023a.ada new file mode 100644 index 000000000..18f80c3c0 --- /dev/null +++ b/gcc/testsuite/ada/acats/tests/c8/c83023a.ada @@ -0,0 +1,194 @@ +-- C83023A.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 A DECLARATION IN A DECLARATIVE REGION OF A TASK +-- HIDES AN OUTER DECLARATION OF A HOMOGRAPH. ALSO CHECK THAT THE +-- OUTER DECLARATION IS DIRECTLY VISIBLE IN BOTH DECLARATIVE +-- REGIONS BEFORE THE DECLARATION OF THE INNER HOMOGRAPH AND THE +-- OUTER DECLARATION IS VISIBLE BY SELECTION AFTER THE INNER +-- HOMOGRAPH DECLARATION. + +-- HISTORY: +-- BCB 08/29/88 CREATED ORIGINAL TEST. + +WITH REPORT; USE REPORT; +PROCEDURE C83023A IS + + GENERIC + TYPE T IS PRIVATE; + X : T; + FUNCTION GEN_FUN RETURN T; + + FUNCTION GEN_FUN RETURN T IS + BEGIN + RETURN X; + END GEN_FUN; + +BEGIN + TEST ("C83023A", "CHECK THAT A DECLARATION IN A DECLARATIVE " & + "REGION OF A TASK HIDES AN OUTER " & + "DECLARATION OF A HOMOGRAPH"); + + ONE: + DECLARE -- DECLARATIVE REGION. + A : INTEGER := IDENT_INT(2); + B : INTEGER := A; + + TASK INNER IS + ENTRY HERE (X : IN OUT INTEGER); + END INNER; + + TASK BODY INNER IS + C : INTEGER := A; + A : INTEGER := IDENT_INT(3); + BEGIN + ACCEPT HERE (X : IN OUT INTEGER) DO + IF A /= IDENT_INT(3) THEN + FAILED ("INCORRECT VALUE FOR INNER HOMOGRAPH" & + " - 1"); + END IF; + + IF ONE.A /= IDENT_INT(2) THEN + FAILED ("INCORRECT VALUE FOR OUTER HOMOGRAPH" & + " - 2"); + END IF; + + IF ONE.B /= IDENT_INT(2) THEN + FAILED ("INCORRECT VALUE FOR OUTER VARIABLE " & + "- 3"); + END IF; + + IF C /= IDENT_INT(2) THEN + FAILED ("INCORRECT VALUE FOR INNER VARIABLE " & + "- 4"); + END IF; + + IF X /= IDENT_INT(2) THEN + FAILED ("INCORRECT VALUE PASSED IN - 5"); + END IF; + + IF EQUAL(1,1) THEN + X := A; + ELSE + X := ONE.A; + END IF; + END HERE; + END INNER; + + BEGIN -- ONE + INNER.HERE(A); + + IF A /= IDENT_INT(3) THEN + FAILED ("INCORRECT VALUE PASSED OUT - 6"); + END IF; + END ONE; + + TWO: + DECLARE -- AFTER THE SPECIFICATION OF TASK. + TASK INNER IS + ENTRY HERE (X : IN OUT INTEGER); + END INNER; + + A : INTEGER := IDENT_INT(2); + + B : INTEGER := A; + + TASK BODY INNER IS + C : INTEGER := A; + A : INTEGER := IDENT_INT(3); + BEGIN + ACCEPT HERE (X : IN OUT INTEGER) DO + IF A /= IDENT_INT(3) THEN + FAILED ("INCORRECT VALUE FOR INNER HOMOGRAPH" & + " - 10"); + END IF; + + IF TWO.A /= IDENT_INT(2) THEN + FAILED ("INCORRECT VALUE FOR OUTER HOMOGRAPH" & + " - 11"); + END IF; + + IF TWO.B /= IDENT_INT(2) THEN + FAILED ("INCORRECT VALUE FOR OUTER VARIABLE " & + "- 12"); + END IF; + + IF C /= IDENT_INT(2) THEN + FAILED ("INCORRECT VALUE FOR INNER VARIABLE " & + "- 13"); + END IF; + + IF X /= IDENT_INT(2) THEN + FAILED ("INCORRECT VALUE PASSED IN - 14"); + END IF; + + IF EQUAL(1,1) THEN + X := A; + ELSE + NULL; + END IF; + END HERE; + END INNER; + + BEGIN -- TWO + INNER.HERE(A); + + IF A /= IDENT_INT(3) THEN + FAILED ("INCORRECT VALUE PASSED OUT - 15"); + END IF; + END TWO; + + THREE: + DECLARE -- OVERLOADING OF FUNCTIONS. + + OBJ : INTEGER := 1; + FLO : FLOAT := 5.0; + + FUNCTION F IS NEW GEN_FUN (INTEGER, OBJ); + + TASK INNER IS + ENTRY HERE (X : IN OUT INTEGER); + END INNER; + + FUNCTION F IS NEW GEN_FUN (FLOAT, FLO); + + TASK BODY INNER IS + F : FLOAT := 6.25; + BEGIN + ACCEPT HERE (X : IN OUT INTEGER) DO + X := INTEGER(F); + END HERE; + END INNER; + + BEGIN + INNER.HERE (OBJ); + + IF OBJ /= IDENT_INT(6) THEN + FAILED ("INCORRECT VALUE RETURNED FROM FUNCTION - 20"); + END IF; + END THREE; + + RESULT; +END C83023A; diff --git a/gcc/testsuite/ada/acats/tests/c8/c83024a.ada b/gcc/testsuite/ada/acats/tests/c8/c83024a.ada new file mode 100644 index 000000000..0ad06b3a1 --- /dev/null +++ b/gcc/testsuite/ada/acats/tests/c8/c83024a.ada @@ -0,0 +1,185 @@ +-- C83024A.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 A DECLARATION IN A DECLARATIVE REGION FOR A GENERIC +-- PACKAGE HIDES AN OUTER DECLARATION OF A HOMOGRAPH. ALSO CHECK +-- THAT THE OUTER DECLARATION IS DIRECTLY VISIBLE IN BOTH +-- DECLARATIVE REGIONS BEFORE THE DECLARATION OF THE INNER HOMOGRAPH +-- AND THE OUTER DECLARATION IS VISIBLE BY SELECTION AFTER THE INNER +-- HOMOGRAH DECLARATION. + +-- HISTORY: +-- BCB 08/30/88 CREATED ORIGINAL TEST. + +WITH REPORT; USE REPORT; + +PROCEDURE C83024A IS + + GENERIC + TYPE T IS PRIVATE; + X : T; + FUNCTION GEN_FUN RETURN T; + + FUNCTION GEN_FUN RETURN T IS + BEGIN + RETURN X; + END GEN_FUN; + +BEGIN + TEST ("C83024A", "CHECK THAT A DECLARATION IN A DECLARATIVE " & + "REGION FOR A GENERIC PACKAGE HIDES AN OUTER " & + "DECLARATION OF A HOMOGRAPH"); + + ONE: + DECLARE + A : INTEGER := IDENT_INT(2); + B : INTEGER := A; + OBJ : INTEGER := IDENT_INT(3); + + GENERIC + X : IN INTEGER := A; + A : IN OUT INTEGER; + PACKAGE INNER IS + C : INTEGER := A; + END INNER; + + PACKAGE BODY INNER IS + BEGIN + IF A /= IDENT_INT(3) THEN + FAILED ("INCORRECT VALUE FOR INNER HOMOGRAPH - 10"); + END IF; + + IF ONE.A /= IDENT_INT(2) THEN + FAILED ("INCORRECT VALUE FOR OUTER HOMOGRAPH - 11"); + END IF; + + IF ONE.B /= IDENT_INT(2) THEN + FAILED ("INCORRECT VALUE FOR OUTER VARIABLE - 12"); + END IF; + + IF C /= IDENT_INT(3) THEN + FAILED ("INCORRECT VALUE FOR INNER VARIABLE - 13"); + END IF; + + IF X /= IDENT_INT(2) THEN + FAILED ("INCORRECT VALUE PASSED IN - 14"); + END IF; + + IF EQUAL(1,1) THEN + A := IDENT_INT(4); + ELSE + A := 1; + END IF; + END INNER; + + PACKAGE NEW_INNER IS NEW INNER (A => OBJ); + + BEGIN -- ONE + IF OBJ /= IDENT_INT(4) THEN + FAILED ("INCORRECT VALUE PASSED OUT - 15"); + END IF; + END ONE; + + TWO: + DECLARE -- AFTER THE SPECIFICATION OF PACKAGE. + A : INTEGER := IDENT_INT(2); + + GENERIC + X : IN OUT INTEGER; + PACKAGE INNER IS + A : INTEGER := IDENT_INT(3); + END INNER; + + B : INTEGER := A; + + PACKAGE BODY INNER IS + C : INTEGER := TWO.A; + BEGIN + IF A /= IDENT_INT(3) THEN + FAILED ("INCORRECT VALUE FOR INNER HOMOGRAPH - 20"); + END IF; + + IF TWO.A /= IDENT_INT(2) THEN + FAILED ("INCORRECT VALUE FOR OUTER HOMOGRAPH - 21"); + END IF; + + IF TWO.B /= IDENT_INT(2) THEN + FAILED ("INCORRECT VALUE FOR OUTER VARIABLE - 22"); + END IF; + + IF C /= IDENT_INT(2) THEN + FAILED ("INCORRECT VALUE FOR INNER VARIABLE - 23"); + END IF; + + IF X /= IDENT_INT(2) THEN + FAILED ("INCORRECT VALUE PASSED IN - 24"); + END IF; + + IF EQUAL(1,1) THEN + X := A; + ELSE + NULL; + END IF; + END INNER; + + PACKAGE NEW_INNER IS NEW INNER (A); + + BEGIN -- TWO + IF A /= IDENT_INT(3) THEN + FAILED ("INCORRECT VALUE PASSED OUT - 25"); + END IF; + END TWO; + + THREE: + DECLARE -- OVERLOADING OF FUNCTIONS. + + OBJ : INTEGER := 1; + FLO : FLOAT := 6.25; + + FUNCTION F IS NEW GEN_FUN (INTEGER, OBJ); + + GENERIC + X : IN OUT INTEGER; + F : IN FLOAT; + PACKAGE INNER IS + END INNER; + + FUNCTION F IS NEW GEN_FUN (FLOAT, FLO); + + PACKAGE BODY INNER IS + BEGIN + X := INTEGER(F); + END INNER; + + PACKAGE NEW_INNER IS NEW INNER (OBJ, FLO); + + BEGIN + IF OBJ /= IDENT_INT(6) THEN + FAILED ("INCORRECT VALUE RETURNED FROM FUNCTION - 60"); + END IF; + END THREE; + + RESULT; +END C83024A; diff --git a/gcc/testsuite/ada/acats/tests/c8/c83024e0.ada b/gcc/testsuite/ada/acats/tests/c8/c83024e0.ada new file mode 100644 index 000000000..e92cffb9d --- /dev/null +++ b/gcc/testsuite/ada/acats/tests/c8/c83024e0.ada @@ -0,0 +1,112 @@ +-- C83024E0.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 A DECLARATION IN THE DECLARATIVE REGION OF A GENERIC +-- PACKAGE HIDES AN OUTER DECLARATION OF A HOMOGRAPH. ALSO CHECK +-- THAT THE OUTER DECLARATION IS DIRECTLY VISIBLE IN BOTH +-- DECLARATIVE REGIONS BEFORE THE DECLARATION OF THE INNER HOMOGRAPH +-- AND THE OUTER DECLARATION IS VISIBLE BY SELECTION AFTER THE INNER +-- HOMOGRAPH DECLARATION, IF THE GENERIC PACKAGE BODY IS SEPARATELY +-- COMPILED, BUT NOT AS A SUBUNIT. + +-- HISTORY: +-- BCB 08/30/88 CREATED ORIGINAL TEST. +-- PWN 11/30/94 ADDED A PROCEDURE TO KEEP PACKAGE BODIES LEGAL. + +GENERIC + TYPE T IS PRIVATE; + X : T; +FUNCTION C83024E_GEN_FUN RETURN T; + +FUNCTION C83024E_GEN_FUN RETURN T IS +BEGIN + RETURN X; +END C83024E_GEN_FUN; + +WITH REPORT; USE REPORT; +PRAGMA ELABORATE(REPORT); +PACKAGE C83024E_P1 IS + A : INTEGER := IDENT_INT(2); + B : INTEGER := A; + + PROCEDURE REQUIRE_BODY; + + GENERIC + X : IN OUT INTEGER; + PACKAGE C83024E_PACK1 IS + C : INTEGER := A; + A : INTEGER := IDENT_INT(3); + END C83024E_PACK1; +END C83024E_P1; + +WITH REPORT; USE REPORT; +PRAGMA ELABORATE(REPORT); +PACKAGE C83024E_P2 IS + A : INTEGER := IDENT_INT(2); + B : INTEGER := A; + OBJ : INTEGER := IDENT_INT(3); + + PROCEDURE REQUIRE_BODY; + + GENERIC + X : IN INTEGER := A; + A : IN OUT INTEGER; + PACKAGE C83024E_PACK2 IS + C : INTEGER := A; + END C83024E_PACK2; +END C83024E_P2; + +WITH REPORT; USE REPORT; +PRAGMA ELABORATE(REPORT); +PACKAGE C83024E_P3 IS + A : INTEGER := IDENT_INT(2); + B : INTEGER := A; + + PROCEDURE REQUIRE_BODY; + + GENERIC + X : IN OUT INTEGER; + PACKAGE C83024E_PACK3 IS + END C83024E_PACK3; +END C83024E_P3; + +WITH REPORT; USE REPORT; +WITH C83024E_GEN_FUN; +PRAGMA ELABORATE(REPORT,C83024E_GEN_FUN); +PACKAGE C83024E_P4 IS + OBJ : INTEGER := IDENT_INT(1); + FLO : FLOAT := 6.25; + + PROCEDURE REQUIRE_BODY; + + FUNCTION F IS NEW C83024E_GEN_FUN (INTEGER, OBJ); + FUNCTION F IS NEW C83024E_GEN_FUN (FLOAT, FLO); + + GENERIC + X : IN OUT INTEGER; + F : IN FLOAT; + PACKAGE C83024E_PACK4 IS + END C83024E_PACK4; +END C83024E_P4; diff --git a/gcc/testsuite/ada/acats/tests/c8/c83024e1.ada b/gcc/testsuite/ada/acats/tests/c8/c83024e1.ada new file mode 100644 index 000000000..d7c1c5b23 --- /dev/null +++ b/gcc/testsuite/ada/acats/tests/c8/c83024e1.ada @@ -0,0 +1,220 @@ +-- C83024E1M.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 A DECLARATION IN THE DECLARATIVE REGION OF A GENERIC +-- PACKAGE HIDES AN OUTER DECLARATION OF A HOMOGRAPH. ALSO CHECK +-- THAT THE OUTER DECLARATION IS DIRECTLY VISIBLE IN BOTH +-- DECLARATIVE REGIONS BEFORE THE DECLARATION OF THE INNER HOMOGRAPH +-- AND THE OUTER DECLARATION IS VISIBLE BY SELECTION AFTER THE INNER +-- HOMOGRAPH DECLARATION, IF THE GENERIC PACKAGE BODY IS SEPARATELY +-- COMPILED, BUT NOT AS A SUBUNIT. + +-- APPLICABILITY CRITERIA: +-- THIS TEST IS APPLICABLE TO IMPLEMENTATIONS THAT SUPPORT SEPARATE +-- COMPILATIONS OF GENERIC SPECIFICATIONS AND BODIES. + +-- SEPARATE FILES ARE: +-- C83024E0.ADA -- GENERIC PACKAGE SPECIFICATIONS. +-- C83024E1M.ADA - (THIS FILE) GENERIC PACKAGE BODIES AND +-- MAIN PROGRAM. + +-- HISTORY: +-- BCB 08/30/88 CREATED ORIGINAL TEST. +-- PWN 11/30/94 ADDED A PROCEDURE TO KEEP PACKAGE BODIES LEGAL. + +PACKAGE BODY C83024E_P1 IS + + PROCEDURE REQUIRE_BODY IS + BEGIN + NULL; + END; + + PACKAGE BODY C83024E_PACK1 IS + BEGIN + IF A /= IDENT_INT(3) THEN + FAILED ("INCORRECT VALUE FOR INNER HOMOGRAPH - 1"); + END IF; + + IF C83024E_P1.A /= IDENT_INT(2) THEN + FAILED ("INCORRECT VALUE FOR OUTER HOMOGRAPH - 2"); + END IF; + + IF C83024E_P1.B /= IDENT_INT(2) THEN + FAILED ("INCORRECT VALUE FOR OUTER VARIABLE - 3"); + END IF; + + IF C /= IDENT_INT(2) THEN + FAILED ("INCORRECT VALUE FOR INNER VARIABLE - 4"); + END IF; + + IF X /= IDENT_INT(2) THEN + FAILED ("INCORRECT VALUE PASSED IN - 5"); + END IF; + + IF EQUAL(1,1) THEN + X := A; + ELSE + X := C83024E_P1.A; + END IF; + END C83024E_PACK1; +END C83024E_P1; + +PACKAGE BODY C83024E_P2 IS + + PROCEDURE REQUIRE_BODY IS + BEGIN + NULL; + END; + + PACKAGE BODY C83024E_PACK2 IS + BEGIN + IF A /= IDENT_INT(3) THEN + FAILED ("INCORRECT VALUE FOR INNER HOMOGRAPH - 10"); + END IF; + + IF C83024E_P2.A /= IDENT_INT(2) THEN + FAILED ("INCORRECT VALUE FOR OUTER HOMOGRAPH - 11"); + END IF; + + IF C83024E_P2.B /= IDENT_INT(2) THEN + FAILED ("INCORRECT VALUE FOR OUTER VARIABLE - 12"); + END IF; + + IF C /= IDENT_INT(3) THEN + FAILED ("INCORRECT VALUE FOR INNER VARIABLE - 13"); + END IF; + + IF X /= IDENT_INT(2) THEN + FAILED ("INCORRECT VALUE PASSED IN - 14"); + END IF; + + IF EQUAL(1,1) THEN + A := IDENT_INT(4); + ELSE + A := 1; + END IF; + END C83024E_PACK2; +END C83024E_P2; + +PACKAGE BODY C83024E_P3 IS + + PROCEDURE REQUIRE_BODY IS + BEGIN + NULL; + END; + + PACKAGE BODY C83024E_PACK3 IS + C : INTEGER := A; + A : INTEGER := IDENT_INT(3); + BEGIN + IF A /= IDENT_INT(3) THEN + FAILED ("INCORRECT VALUE FOR INNER HOMOGRAPH - 20"); + END IF; + + IF C83024E_P3.A /= IDENT_INT(2) THEN + FAILED ("INCORRECT VALUE FOR OUTER HOMOGRAPH - 21"); + END IF; + + IF C83024E_P3.B /= IDENT_INT(2) THEN + FAILED ("INCORRECT VALUE FOR OUTER VARIABLE - 22"); + END IF; + + IF C /= IDENT_INT(2) THEN + FAILED ("INCORRECT VALUE FOR INNER VARIABLE - 23"); + END IF; + + IF X /= IDENT_INT(2) THEN + FAILED ("INCORRECT VALUE PASSED IN - 24"); + END IF; + + IF EQUAL(1,1) THEN + X := A; + ELSE + NULL; + END IF; + END C83024E_PACK3; +END C83024E_P3; + +PACKAGE BODY C83024E_P4 IS + + PROCEDURE REQUIRE_BODY IS + BEGIN + NULL; + END; + + PACKAGE BODY C83024E_PACK4 IS + BEGIN + X := INTEGER(F); + END C83024E_PACK4; +END C83024E_P4; + +WITH REPORT; USE REPORT; +WITH C83024E_P1; WITH C83024E_P2; +WITH C83024E_P3; WITH C83024E_P4; +USE C83024E_P1; USE C83024E_P2; +USE C83024E_P3; USE C83024E_P4; +PROCEDURE C83024E1M IS + +BEGIN + TEST ("C83024E", "CHECK THAT A DECLARATION IN THE DECLARATIVE " & + "REGION OF A GENERIC PACKAGE HIDES AN OUTER " & + "DECLARATION OF A HOMOGRAPH"); + + DECLARE + PACKAGE NEW_C83024E_PACK1 IS NEW C83024E_PACK1 (C83024E_P1.A); + BEGIN + IF C83024E_P1.A /= IDENT_INT(3) THEN + FAILED ("INCORRECT VALUE PASSED OUT - 6"); + END IF; + END; + + DECLARE + PACKAGE NEW_C83024E_PACK2 IS + NEW C83024E_PACK2 (A => C83024E_P2.OBJ); + BEGIN + IF C83024E_P2.OBJ /= IDENT_INT(4) THEN + FAILED ("INCORRECT VALUE PASSED OUT - 15"); + END IF; + END; + + DECLARE + PACKAGE NEW_C83024E_PACK3 IS NEW C83024E_PACK3 (C83024E_P3.A); + BEGIN + IF C83024E_P3.A /= IDENT_INT(3) THEN + FAILED ("INCORRECT VALUE PASSED OUT - 25"); + END IF; + END; + + DECLARE + PACKAGE NEW_C83024E_PACK4 IS + NEW C83024E_PACK4 (C83024E_P4.OBJ, FLO); + BEGIN + IF C83024E_P4.OBJ /= IDENT_INT(6) THEN + FAILED ("INCORRECT VALUE RETURNED FROM FUNCTION - 60"); + END IF; + END; + + RESULT; +END C83024E1M; diff --git a/gcc/testsuite/ada/acats/tests/c8/c83025a.ada b/gcc/testsuite/ada/acats/tests/c8/c83025a.ada new file mode 100644 index 000000000..aff1914eb --- /dev/null +++ b/gcc/testsuite/ada/acats/tests/c8/c83025a.ada @@ -0,0 +1,283 @@ +-- C83025A.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 A DECLARATION IN THE DECLARATIVE REGION OF A GENERIC +-- SUBPROGRAM HIDES AN OUTER DECLARATION OF A HOMOGRAPH. ALSO CHECK +-- THAT THE OUTER DECLARATION IS DIRECTLY VISIBLE IN BOTH +-- DECLARATIVE REGIONS BEFORE THE DECLARATION OF THE INNER HOMOGRAPH +-- AND THE OUTER DECLARATION IS VISIBLE BY SELECTION AFTER THE INNER +-- HOMOGRAPH DECLARATION. + +-- HISTORY: +-- BCB 08/31/88 CREATED ORIGINAL TEST. + +WITH REPORT; USE REPORT; + +PROCEDURE C83025A IS + + GENERIC + TYPE T IS PRIVATE; + X : T; + FUNCTION GEN_FUN RETURN T; + + FUNCTION GEN_FUN RETURN T IS + BEGIN + RETURN X; + END GEN_FUN; + +BEGIN + TEST ("C83025A", "CHECK THAT A DECLARATION IN THE DECLARATIVE " & + "REGION OF A GENERIC SUBPROGRAM HIDES AN OUTER " & + "DECLARATION OF A HOMOGRAPH"); + + ONE: + DECLARE -- SUBPROGRAM DECLARATIVE REGION. + A : INTEGER := IDENT_INT(2); + B : INTEGER := A; + + GENERIC + PROCEDURE INNER (X : IN OUT INTEGER); + + PROCEDURE INNER (X : IN OUT INTEGER) IS + C : INTEGER := A; + A : INTEGER := IDENT_INT(3); + BEGIN + IF A /= IDENT_INT(3) THEN + FAILED ("INCORRECT VALUE FOR INNER HOMOGRAPH - 1"); + END IF; + + IF ONE.A /= IDENT_INT(2) THEN + FAILED ("INCORRECT VALUE FOR OUTER HOMOGRAPH - 2"); + END IF; + + IF ONE.B /= IDENT_INT(2) THEN + FAILED ("INCORRECT VALUE FOR OUTER VARIABLE - 3"); + END IF; + + IF C /= IDENT_INT(2) THEN + FAILED ("INCORRECT VALUE FOR INNER VARIABLE - 4"); + END IF; + + IF X /= IDENT_INT(2) THEN + FAILED ("INCORRECT VALUE PASSED IN - 5"); + END IF; + + IF EQUAL(1,1) THEN + X := A; + ELSE + X := ONE.A; + END IF; + END INNER; + + PROCEDURE NEW_INNER IS NEW INNER; + + BEGIN -- ONE + NEW_INNER (A); + + IF A /= IDENT_INT(3) THEN + FAILED ("INCORRECT VALUE PASSED OUT - 6"); + END IF; + END ONE; + + TWO: + DECLARE -- FORMAL PARAMETER OF GENERIC SUBPROGRAM. + A : INTEGER := IDENT_INT(2); + B : INTEGER := A; + OBJ : INTEGER := IDENT_INT(3); + + GENERIC + PROCEDURE INNER (X : IN INTEGER := A; + A : IN OUT INTEGER); + + PROCEDURE INNER (X : IN INTEGER := TWO.A; + A : IN OUT INTEGER) IS + C : INTEGER := A; + BEGIN + IF A /= IDENT_INT(3) THEN + FAILED ("INCORRECT VALUE FOR INNER HOMOGRAPH -10"); + END IF; + + IF TWO.A /= IDENT_INT(2) THEN + FAILED ("INCORRECT VALUE FOR OUTER HOMOGRAPH - 11"); + END IF; + + IF TWO.B /= IDENT_INT(2) THEN + FAILED ("INCORRECT VALUE FOR OUTER VARIABLE - 12"); + END IF; + + IF C /= IDENT_INT(3) THEN + FAILED ("INCORRECT VALUE FOR INNER VARIABLE - 13"); + END IF; + + IF X /= IDENT_INT(2) THEN + FAILED ("INCORRECT VALUE PASSED IN - 14"); + END IF; + + IF EQUAL(1,1) THEN + A := IDENT_INT(4); + ELSE + A := 1; + END IF; + END INNER; + + PROCEDURE NEW_INNER IS NEW INNER; + + BEGIN -- TWO + NEW_INNER (A => OBJ); + + IF OBJ /= IDENT_INT(4) THEN + FAILED ("INCORRECT VALUE PASSED OUT - 15"); + END IF; + END TWO; + + THREE: + DECLARE -- AFTER THE SPECIFICATION OF GENERIC SUBPROGRAM. + GENERIC + A : INTEGER := IDENT_INT(3); + FUNCTION INNER (X : INTEGER) RETURN INTEGER; + + A : INTEGER := IDENT_INT(2); + + B : INTEGER := A; + + FUNCTION INNER (X : INTEGER) RETURN INTEGER IS + C : INTEGER := THREE.A; + BEGIN + IF A /= IDENT_INT(3) THEN + FAILED ("INCORRECT VALUE FOR INNER HOMOGRAPH - 20"); + END IF; + + IF THREE.A /= IDENT_INT(2) THEN + FAILED ("INCORRECT VALUE FOR OUTER HOMOGRAPH - 21"); + END IF; + + IF THREE.B /= IDENT_INT(2) THEN + FAILED ("INCORRECT VALUE FOR OUTER VARIABLE - 22"); + END IF; + + IF C /= IDENT_INT(2) THEN + FAILED ("INCORRECT VALUE FOR INNER VARIABLE - 23"); + END IF; + + IF X /= IDENT_INT(2) THEN + FAILED ("INCORRECT VALUE PASSED IN - 24"); + END IF; + + IF EQUAL(1,1) THEN + RETURN A; + ELSE + RETURN X; + END IF; + END INNER; + + FUNCTION NEW_INNER IS NEW INNER; + + BEGIN -- THREE + IF NEW_INNER(A) /= IDENT_INT(3) THEN + FAILED ("INCORRECT VALUE PASSED OUT - 25"); + END IF; + END THREE; + + FOUR: + DECLARE + A : INTEGER := IDENT_INT(2); + + GENERIC + A : INTEGER; + B : INTEGER := A; + PROCEDURE INNER (X : IN OUT INTEGER); + + PROCEDURE INNER (X : IN OUT INTEGER) IS + C : INTEGER := FOUR.A; + BEGIN + IF A /= IDENT_INT(3) THEN + FAILED ("INCORRECT VALUE FOR INNER HOMOGRAPH - 30"); + END IF; + + IF B /= IDENT_INT(3) THEN + FAILED ("INCORRECT VALUE FOR INNER VARIABLE - 31"); + END IF; + + IF FOUR.A /= IDENT_INT(2) THEN + FAILED ("INCORRECT VALUE FOR OUTER HOMOGRAPH - 32"); + END IF; + + IF C /= IDENT_INT(2) THEN + FAILED ("INCORRECT VALUE FOR INNER VARIABLE - 33"); + END IF; + + IF X /= IDENT_INT(2) THEN + FAILED ("INCORRECT VALUE PASSED IN - 34"); + END IF; + + IF EQUAL(1,1) THEN + X := A; + ELSE + X := FOUR.A; + END IF; + END INNER; + + PROCEDURE NEW_INNER IS NEW INNER (A => IDENT_INT(3)); + + BEGIN + NEW_INNER (A); + + IF A /= IDENT_INT(3) THEN + FAILED ("INCORRECT VALUE PASSED OUT - 35"); + END IF; + END FOUR; + + FIVE: + DECLARE -- OVERLOADING OF FUNCTIONS. + + OBJ : INTEGER := 1; + FLO : FLOAT := 5.0; + + FUNCTION F IS NEW GEN_FUN (INTEGER, OBJ); + + GENERIC + PROCEDURE INNER (X : IN OUT INTEGER; F : IN FLOAT); + + FUNCTION F IS NEW GEN_FUN (FLOAT, FLO); + + PROCEDURE INNER (X : IN OUT INTEGER; F : IN FLOAT) IS + BEGIN + X := INTEGER(F); + END INNER; + + PROCEDURE NEW_INNER IS NEW INNER; + + BEGIN -- FIVE + FLO := 6.25; + + NEW_INNER (OBJ, FLO); + + IF OBJ /= IDENT_INT(6) THEN + FAILED ("INCORRECT VALUE RETURNED FROM FUNCTION - 40"); + END IF; + END FIVE; + + RESULT; +END C83025A; diff --git a/gcc/testsuite/ada/acats/tests/c8/c83025c.ada b/gcc/testsuite/ada/acats/tests/c8/c83025c.ada new file mode 100644 index 000000000..b21d26898 --- /dev/null +++ b/gcc/testsuite/ada/acats/tests/c8/c83025c.ada @@ -0,0 +1,345 @@ +-- C83025C.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 A DECLARATION IN A DECLARATIVE REGION OF A GENERIC +-- SUBPROGRAM HIDES AN OUTER DECLARATION OF A HOMOGRAPH. ALSO CHECK +-- THAT THE OUTER DECLARATION IS DIRECTLY VISIBLE IN BOTH +-- DECLARATIVE REGIONS BEFORE THE DECLARATION OF THE INNER HOMOGRAPH +-- AND THE OUTER DECLARATION IS VISIBLE BY SELECTION AFTER THE INNER +-- HOMOGRAPH DECLARATION, IF THE GENERIC SUBPROGRAM BODY IS COMPILED +-- AS A SUBUNIT IN THE SAME COMPILATION. + +-- HISTORY: +-- BCB 09/01/88 CREATED ORIGINAL TEST. + +WITH REPORT; USE REPORT; +PRAGMA ELABORATE(REPORT); +PACKAGE C83025C_PACK IS + Y : INTEGER := IDENT_INT(5); + Z : INTEGER := Y; + + GENERIC + TYPE T IS PRIVATE; + X : T; + FUNCTION GEN_FUN RETURN T; + + A : INTEGER := IDENT_INT(2); + B : INTEGER := A; + + OBJ : INTEGER := IDENT_INT(3); + + FLO : FLOAT := 5.0; + + TYPE ENUM IS (ONE, TWO, THREE, FOUR); + + EOBJ : ENUM := ONE; + + GENERIC + Y : FLOAT := 2.0; + PROCEDURE INNER (X : IN OUT INTEGER); + + GENERIC + Y : BOOLEAN := TRUE; + PROCEDURE INNER2 (X : IN INTEGER := A; + A : IN OUT INTEGER); + + GENERIC + Y : ENUM := ONE; + FUNCTION INNER3 (X : INTEGER; Z : ENUM := Y) RETURN INTEGER; + + GENERIC + Y : ENUM; + FUNCTION INNER4 (X : INTEGER; Z : ENUM := Y) RETURN INTEGER; + + GENERIC + Y : CHARACTER := 'A'; + PROCEDURE INNER5 (X : IN OUT INTEGER; F : IN FLOAT; + Z : CHARACTER := Y); +END C83025C_PACK; + +PACKAGE BODY C83025C_PACK IS + FUNCTION GEN_FUN RETURN T IS + BEGIN + RETURN X; + END GEN_FUN; + + FUNCTION F IS NEW GEN_FUN (INTEGER, OBJ); + + FUNCTION F IS NEW GEN_FUN (FLOAT, FLO); + + PROCEDURE INNER (X : IN OUT INTEGER) IS SEPARATE; + + PROCEDURE INNER2 (X : IN INTEGER := C83025C_PACK.A; + A : IN OUT INTEGER) IS SEPARATE; + + FUNCTION INNER3 (X : INTEGER; + Z : ENUM := Y) RETURN INTEGER IS SEPARATE; + + FUNCTION INNER4 (X : INTEGER; + Z : ENUM := Y) RETURN INTEGER IS SEPARATE; + + PROCEDURE INNER5 (X : IN OUT INTEGER; F : IN FLOAT; + Z : CHARACTER := Y) IS SEPARATE; +END C83025C_PACK; + +SEPARATE (C83025C_PACK) +PROCEDURE INNER (X : IN OUT INTEGER) IS + C : INTEGER := A; + A : INTEGER := IDENT_INT(3); +BEGIN + IF A /= IDENT_INT(3) THEN + FAILED ("INCORRECT VALUE FOR INNER HOMOGRAPH - 1"); + END IF; + + IF C83025C_PACK.A /= IDENT_INT(2) THEN + FAILED ("INCORRECT VALUE FOR OUTER HOMOGRAPH - 2"); + END IF; + + IF C83025C_PACK.B /= IDENT_INT(2) THEN + FAILED ("INCORRECT VALUE FOR OUTER VARIABLE - 3"); + END IF; + + IF C /= IDENT_INT(2) THEN + FAILED ("INCORRECT VALUE FOR INNER VARIABLE - 4"); + END IF; + + IF X /= IDENT_INT(2) THEN + FAILED ("INCORRECT VALUE PASSED IN - 5"); + END IF; + + IF Y /= 2.0 THEN + FAILED ("INCORRECT VALUE INNER HOMOGRAPH - 6"); + END IF; + + IF EQUAL(1,1) THEN + X := A; + ELSE + X := C83025C_PACK.A; + END IF; +END INNER; + +SEPARATE (C83025C_PACK) +PROCEDURE INNER2 (X : IN INTEGER := C83025C_PACK.A; + A : IN OUT INTEGER) IS + C : INTEGER := A; +BEGIN + IF A /= IDENT_INT(3) THEN + FAILED ("INCORRECT VALUE FOR INNER HOMOGRAPH - 10"); + END IF; + + IF C83025C_PACK.A /= IDENT_INT(2) THEN + FAILED ("INCORRECT VALUE FOR OUTER HOMOGRAPH - 11"); + END IF; + + IF C83025C_PACK.B /= IDENT_INT(2) THEN + FAILED ("INCORRECT VALUE FOR OUTER VARIABLE - 12"); + END IF; + + IF C /= IDENT_INT(3) THEN + FAILED ("INCORRECT VALUE FOR INNER VARIABLE - 13"); + END IF; + + IF X /= IDENT_INT(2) THEN + FAILED ("INCORRECT VALUE PASSED IN - 14"); + END IF; + + IF Y /= TRUE THEN + FAILED ("INCORRECT VALUE FOR INNER HOMOGRAPH - 15"); + END IF; + + IF EQUAL(1,1) THEN + A := IDENT_INT(4); + ELSE + A := 1; + END IF; +END INNER2; + +SEPARATE (C83025C_PACK) +FUNCTION INNER3 (X : INTEGER; Z : ENUM := Y) RETURN INTEGER IS + C : INTEGER := A; + A : INTEGER := IDENT_INT(3); +BEGIN + IF A /= IDENT_INT(3) THEN + FAILED ("INCORRECT VALUE FOR INNER HOMOGRAPH - 20"); + END IF; + + IF C83025C_PACK.A /= IDENT_INT(2) THEN + FAILED ("INCORRECT VALUE FOR OUTER HOMOGRAPH - 21"); + END IF; + + IF C83025C_PACK.B /= IDENT_INT(2) THEN + FAILED ("INCORRECT VALUE FOR OUTER VARIABLE - 22"); + END IF; + + IF C /= IDENT_INT(2) THEN + FAILED ("INCORRECT VALUE FOR INNER VARIABLE - 23"); + END IF; + + IF X /= IDENT_INT(2) THEN + FAILED ("INCORRECT VALUE PASSED IN - 24"); + END IF; + + IF Y /= ONE THEN + FAILED ("INCORRECT VALUE FOR INNER HOMOGRAPH - 25"); + END IF; + + IF Z /= ONE THEN + FAILED ("INCORRECT VALUE FOR INNER HOMOGRAPH - 26"); + END IF; + + IF EQUAL(1,1) THEN + RETURN A; + ELSE + RETURN X; + END IF; +END INNER3; + +SEPARATE (C83025C_PACK) +FUNCTION INNER4 (X : INTEGER; Z : ENUM := Y) RETURN INTEGER IS + C : INTEGER := A; + A : INTEGER := IDENT_INT(3); +BEGIN + IF A /= IDENT_INT(3) THEN + FAILED ("INCORRECT VALUE FOR INNER HOMOGRAPH - 30"); + END IF; + + IF C83025C_PACK.A /= IDENT_INT(2) THEN + FAILED ("INCORRECT VALUE FOR OUTER HOMOGRAPH - 31"); + END IF; + + IF C83025C_PACK.B /= IDENT_INT(2) THEN + FAILED ("INCORRECT VALUE FOR OUTER VARIABLE - 32"); + END IF; + + IF C /= IDENT_INT(2) THEN + FAILED ("INCORRECT VALUE FOR INNER VARIABLE - 33"); + END IF; + + IF X /= IDENT_INT(2) THEN + FAILED ("INCORRECT VALUE PASSED IN - 34"); + END IF; + + IF Y /= ONE THEN + FAILED ("INCORRECT VALUE FOR INNER HOMOGRAPH - 35"); + END IF; + + IF Z /= ONE THEN + FAILED ("INCORRECT VALUE FOR INNER HOMOGRAPH - 36"); + END IF; + + IF EQUAL(1,1) THEN + RETURN A; + ELSE + RETURN X; + END IF; +END INNER4; + +SEPARATE (C83025C_PACK) +PROCEDURE INNER5 (X : IN OUT INTEGER; F : IN FLOAT; + Z : CHARACTER := Y) IS +BEGIN + X := INTEGER(F); + + IF Y /= 'A' THEN + FAILED ("INCORRECT VALUE FOR INNER HOMOGRAPH - 40"); + END IF; + + IF Z /= 'A' THEN + FAILED ("INCORRECT VALUE FOR INNER VARIABLE - 41"); + END IF; +END INNER5; + +WITH REPORT; USE REPORT; +WITH C83025C_PACK; USE C83025C_PACK; +PROCEDURE C83025C IS + + PROCEDURE NEW_INNER IS NEW INNER; + + PROCEDURE NEW_INNER2 IS NEW INNER2; + + FUNCTION NEW_INNER3 IS NEW INNER3; + + FUNCTION NEW_INNER4 IS NEW INNER4 (Y => EOBJ); + + PROCEDURE NEW_INNER5 IS NEW INNER5; + +BEGIN + TEST ("C83025C", "CHECK THAT A DECLARATION IN A DECLARATIVE " & + "REGION OF A GENERIC SUBPROGRAM HIDES AN OUTER " & + "DECLARATION OF A HOMOGRAPH"); + + A := IDENT_INT(2); + B := A; + + NEW_INNER (A); + + IF A /= IDENT_INT(3) THEN + FAILED ("INCORRECT VALUE PASSED OUT - 7"); + END IF; + + A := IDENT_INT(2); + + NEW_INNER2 (A => OBJ); + + IF OBJ /= IDENT_INT(4) THEN + FAILED ("INCORRECT VALUE PASSED OUT - 16"); + END IF; + + A := IDENT_INT(2); + + B := A; + + IF NEW_INNER3(A) /= IDENT_INT(3) THEN + FAILED ("INCORRECT VALUE PASSED OUT - 27"); + END IF; + + A := IDENT_INT(2); + + B := A; + + IF NEW_INNER4(A) /= IDENT_INT(3) THEN + FAILED ("INCORRECT VALUE PASSED OUT - 37"); + END IF; + + OBJ := 1; + + FLO := 6.25; + + NEW_INNER5 (OBJ, FLO); + + IF OBJ /= IDENT_INT(6) THEN + FAILED ("INCORRECT VALUE RETURNED FROM FUNCTION - 42"); + END IF; + + IF Y /= 5 THEN + FAILED ("INCORRECT VALUE FOR OUTER HOMOGRAPH - 50"); + END IF; + + IF Z /= 5 THEN + FAILED ("INCORRECT VALUE FOR OUTER VARIABLE - 51"); + END IF; + + RESULT; +END C83025C; diff --git a/gcc/testsuite/ada/acats/tests/c8/c83027a.ada b/gcc/testsuite/ada/acats/tests/c8/c83027a.ada new file mode 100644 index 000000000..ba7c12386 --- /dev/null +++ b/gcc/testsuite/ada/acats/tests/c8/c83027a.ada @@ -0,0 +1,188 @@ +-- C83027A.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 A DECLARATION IN A RECORD DECLARATION HIDES AN OUTER +-- DECLARATION OF A HOMOGRAPH. ALSO CHECK THAT THE OUTER DECLARATION +-- IS DIRECTLY VISIBLE IN BOTH DECLARATIVE REGIONS BEFORE THE +-- DECLARATION OF THE INNER HOMOGRAPH AND THE OUTER DECLARATION IS +-- VISIBLE BY SELECTION AFTER THE INNER HOMOGRAPH DECLARATION. + +-- HISTORY: +-- BCB 09/02/88 CREATED ORIGINAL TEST. + +WITH REPORT; USE REPORT; +PROCEDURE C83027A IS + + GENERIC + TYPE T IS PRIVATE; + X : T; + FUNCTION GEN_FUN RETURN T; + + FUNCTION GEN_FUN RETURN T IS + BEGIN + RETURN X; + END GEN_FUN; + +BEGIN + TEST ("C83027A", "CHECK THAT A DECLARATION IN A RECORD " & + "DECLARATION HIDES AN OUTER DECLARATION OF " & + "A HOMOGRAPH"); + + ONE: + DECLARE + A : INTEGER := IDENT_INT(2); + OBJ : INTEGER := IDENT_INT(3); + + TYPE INNER2 (A : INTEGER := IDENT_INT(3)) IS RECORD + C : INTEGER := ONE.A; + D : INTEGER := A; + END RECORD; + + E : INTEGER := A; + + RECVAR : INNER2; + + BEGIN -- ONE + IF A /= IDENT_INT(2) THEN + FAILED ("INCORRECT VALUE FOR OUTER HOMOGRAPH - 1"); + END IF; + + IF RECVAR.A /= IDENT_INT(3) THEN + FAILED ("INCORRECT VALUE FOR INNER HOMOGRAPH - 2"); + END IF; + + IF E /= IDENT_INT(2) THEN + FAILED ("INCORRECT VALUE FOR OUTER VARIABLE - 3"); + END IF; + + IF RECVAR.C /= IDENT_INT(2) THEN + FAILED ("INCORRECT VALUE FOR INNER VARIABLE - 4"); + END IF; + + IF RECVAR.D /= IDENT_INT(3) THEN + FAILED ("INCORRECT VALUE FOR INNER VARIABLE - 5"); + END IF; + + IF EQUAL(1,1) THEN + OBJ := RECVAR.A; + ELSE + OBJ := 1; + END IF; + + IF OBJ /= IDENT_INT(3) THEN + FAILED ("INCORRECT VALUE PASSED OUT - 6"); + END IF; + END ONE; + + TWO: + DECLARE + + GENERIC + A : INTEGER := IDENT_INT(2); + B : INTEGER := A; + PACKAGE P IS + TYPE INNER (C : INTEGER := A; + A : INTEGER := IDENT_INT(3)) IS RECORD + D : INTEGER := A; + END RECORD; + END P; + + PACKAGE BODY P IS + RECVAR : INNER; + BEGIN + IF RECVAR.A /= IDENT_INT(3) THEN + FAILED ("INCORRECT VALUE FOR INNER HOMOGRAPH - 10"); + END IF; + + IF A /= IDENT_INT(2) THEN + FAILED ("INCORRECT VALUE FOR OUTER HOMOGRAPH - 11"); + END IF; + + IF B /= IDENT_INT(2) THEN + FAILED ("INCORRECT VALUE FOR OUTER VARIABLE - 12"); + END IF; + + IF RECVAR.C /= IDENT_INT(2) THEN + FAILED ("INCORRECT VALUE FOR INNER VARIABLE - 13"); + END IF; + + IF RECVAR.D /= IDENT_INT(3) THEN + FAILED ("INCORRECT VALUE FOR INNER VARIABLE - 14"); + END IF; + END P; + + PACKAGE PACK IS NEW P; + + BEGIN -- TWO + NULL; + END TWO; + + THREE: + DECLARE + A : INTEGER := IDENT_INT(2); + OBJ : INTEGER := IDENT_INT(3); + + TYPE INNER4 (C : INTEGER := A; + A : INTEGER := IDENT_INT(3); + X : INTEGER := THREE.A) IS RECORD + D : INTEGER := A; + END RECORD; + + RECVAR : INNER4; + + BEGIN -- THREE + IF A /= IDENT_INT(2) THEN + FAILED ("INCORRECT VALUE FOR OUTER HOMOGRAPH - 20"); + END IF; + + IF RECVAR.A /= IDENT_INT(3) THEN + FAILED ("INCORRECT VALUE FOR INNER HOMOGRAPH - 21"); + END IF; + + IF RECVAR.C /= IDENT_INT(2) THEN + FAILED ("INCORRECT VALUE FOR INNER VARIABLE - 22"); + END IF; + + IF RECVAR.D /= IDENT_INT(3) THEN + FAILED ("INCORRECT VALUE FOR INNER VARIABLE - 23"); + END IF; + + IF RECVAR.X /= IDENT_INT(2) THEN + FAILED ("INCORRECT VALUE FOR INNER VARIABLE - 24"); + END IF; + + IF EQUAL(1,1) THEN + OBJ := RECVAR.A; + ELSE + OBJ := 1; + END IF; + + IF OBJ /= IDENT_INT(3) THEN + FAILED ("INCORRECT VALUE PASSED OUT - 25"); + END IF; + END THREE; + + RESULT; +END C83027A; diff --git a/gcc/testsuite/ada/acats/tests/c8/c83027c.ada b/gcc/testsuite/ada/acats/tests/c8/c83027c.ada new file mode 100644 index 000000000..2950135d1 --- /dev/null +++ b/gcc/testsuite/ada/acats/tests/c8/c83027c.ada @@ -0,0 +1,157 @@ +-- C83027C.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 A DECLARATION WITHIN THE DISCRIMINANT PART OF A +-- PRIVATE TYPE DECLARATION, AN INCOMPLETE TYPE DECLARATION, AND A +-- GENERIC FORMAL TYPE DECLARATION HIDES AN OUTER DECLARATION OF A +-- HOMOGRAPH. ALSO, CHECK THAT THE OUTER DECLARATION IS DIRECTLY +-- VISIBLE IN BOTH DECLARATIVE REGIONS BEFORE THE DECLARATION OF THE +-- INNER HOMOGRAPH AND THE OUTER DECLARATION IS VISIBLE BY SELECTION +-- AFTER THE INNER HOMOGRAPH DECLARATION. + +-- HISTORY: +-- BCB 09/06/88 CREATED ORIGINAL TEST. + +WITH REPORT; USE REPORT; +PROCEDURE C83027C IS + + GENERIC + TYPE T IS PRIVATE; + X : T; + FUNCTION GEN_FUN RETURN T; + + FUNCTION GEN_FUN RETURN T IS + BEGIN + RETURN X; + END GEN_FUN; + +BEGIN + TEST ("C83027C", "CHECK THAT A DECLARATION IN THE DISCRIMINANT " & + "PART OF A PRIVATE TYPE DECLARATION, AN " & + "INCOMPLETE TYPE DECLARATION, AND A GENERIC " & + "FORMAL TYPE DECLARATION HIDES AN OUTER " & + "DECLARATION OF A HOMOGRAPH"); + + ONE: + DECLARE + A : INTEGER := IDENT_INT(2); + + D : INTEGER := IDENT_INT(2); + + G : INTEGER := IDENT_INT(2); + H : INTEGER := G; + + TYPE REC (Z : INTEGER) IS RECORD + NULL; + END RECORD; + + GENERIC + TYPE INNER3 (G : INTEGER) IS PRIVATE; + PACKAGE P_ONE IS + TYPE INNER (X : INTEGER := A; + A : INTEGER := IDENT_INT(3); + C : INTEGER := ONE.A) IS PRIVATE; + TYPE INNER2 (Y : INTEGER := D; + D : INTEGER := IDENT_INT(3); + F : INTEGER := ONE.D); + TYPE INNER2 (Y : INTEGER := D; + D : INTEGER := IDENT_INT(3); + F : INTEGER := ONE.D) IS RECORD + E : INTEGER := D; + END RECORD; + PRIVATE + TYPE INNER (X : INTEGER := A; + A : INTEGER := IDENT_INT(3); + C : INTEGER := ONE.A) IS RECORD + B : INTEGER := A; + END RECORD; + END P_ONE; + + PACKAGE BODY P_ONE IS + RECVAR : INNER; + RECVAR2 : INNER2; + RECVAR3 : INNER3(3); + BEGIN + IF RECVAR.A /= IDENT_INT(3) THEN + FAILED ("INCORRECT VALUE FOR INNER HOMOGRAPH - 1"); + END IF; + + IF A /= IDENT_INT(2) THEN + FAILED ("INCORRECT VALUE FOR OUTER HOMOGRAPH - 2"); + END IF; + + IF RECVAR.B /= IDENT_INT(3) THEN + FAILED ("INCORRECT VALUE FOR INNER VARIABLE - 3"); + END IF; + + IF RECVAR.C /= IDENT_INT(2) THEN + FAILED ("INCORRECT VALUE FOR INNER VARIABLE - 4"); + END IF; + + IF RECVAR.X /= IDENT_INT(2) THEN + FAILED ("INCORRECT VALUE FOR INNER VARIABLE - 5"); + END IF; + + IF RECVAR2.D /= IDENT_INT(3) THEN + FAILED ("INCORRECT VALUE FOR INNER HOMOGRAPH - 6"); + END IF; + + IF D /= IDENT_INT(2) THEN + FAILED ("INCORRECT VALUE FOR OUTER HOMOGRAPH - 7"); + END IF; + + IF RECVAR2.E /= IDENT_INT(3) THEN + FAILED ("INCORRECT VALUE FOR INNER VARIABLE - 8"); + END IF; + + IF RECVAR2.F /= IDENT_INT(2) THEN + FAILED ("INCORRECT VALUE FOR INNER VARIABLE - 9"); + END IF; + + IF RECVAR2.Y /= IDENT_INT(2) THEN + FAILED ("INCORRECT VALUE FOR INNER VARIABLE - 10"); + END IF; + + IF RECVAR3.G /= IDENT_INT(3) THEN + FAILED ("INCORRECT VALUE FOR INNER HOMOGRAPH - 11"); + END IF; + + IF G /= IDENT_INT(2) THEN + FAILED ("INCORRECT VALUE FOR OUTER HOMOGRAPH - 12"); + END IF; + + IF H /= IDENT_INT(2) THEN + FAILED ("INCORRECT VALUE FOR OUTER VARIABLE - 13"); + END IF; + END P_ONE; + + PACKAGE NEW_P_ONE IS NEW P_ONE (REC); + + BEGIN -- ONE + NULL; + END ONE; + + RESULT; +END C83027C; diff --git a/gcc/testsuite/ada/acats/tests/c8/c83028a.ada b/gcc/testsuite/ada/acats/tests/c8/c83028a.ada new file mode 100644 index 000000000..7aa7af033 --- /dev/null +++ b/gcc/testsuite/ada/acats/tests/c8/c83028a.ada @@ -0,0 +1,156 @@ +-- C83028A.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 A DECLARATION IN A BLOCK STATEMENT HIDES AN OUTER +-- DECLARATION OF A HOMOGRAPH. ALSO CHECK THAT THE OUTER DECLARATION +-- IS DIRECTLY VISIBLE IN BOTH DECLARATIVE REGIONS BEFORE THE +-- DECLARATION OF THE INNER HOMOGRAPH AND THE OUTER DECLARATION IS +-- VISIBLE BY SELECTION AFTER THE INNER HOMOGRAPH DECLARATION. + +-- HISTORY: +-- BCB 09/06/88 CREATED ORIGINAL TEST. + +WITH REPORT; USE REPORT; +PROCEDURE C83028A IS + + GENERIC + TYPE T IS PRIVATE; + X : T; + FUNCTION GEN_FUN RETURN T; + + FUNCTION GEN_FUN RETURN T IS + BEGIN + RETURN X; + END GEN_FUN; + +BEGIN + TEST ("C83028A", "CHECK THAT A DECLARATION IN A BLOCK " & + "STATEMENT HIDES AN OUTER " & + "DECLARATION OF A HOMOGRAPH"); + + ONE: + DECLARE + A : INTEGER := IDENT_INT(2); + B : INTEGER := A; + + BEGIN -- ONE + DECLARE + C : INTEGER := A; + A : INTEGER := IDENT_INT(3); + BEGIN + IF A /= IDENT_INT(3) THEN + FAILED ("INCORRECT VALUE FOR INNER HOMOGRAPH - 1"); + END IF; + + IF ONE.A /= IDENT_INT(2) THEN + FAILED ("INCORRECT VALUE FOR OUTER HOMOGRAPH - 2"); + END IF; + + IF ONE.B /= IDENT_INT(2) THEN + FAILED ("INCORRECT VALUE FOR OUTER VARIABLE - 3"); + END IF; + + IF C /= IDENT_INT(2) THEN + FAILED ("INCORRECT VALUE FOR INNER VARIABLE - 4"); + END IF; + + IF EQUAL(1,1) THEN + ONE.A := A; + END IF; + END; + + IF A /= IDENT_INT(3) THEN + FAILED ("INCORRECT VALUE PASSED OUT - 6"); + END IF; + END ONE; + + TWO: + DECLARE + A : INTEGER := IDENT_INT(2); + B : INTEGER := A; + OBJ : INTEGER := IDENT_INT(3); + + BEGIN -- TWO + DECLARE + X : INTEGER := A; + A : INTEGER := OBJ; + C : INTEGER := A; + BEGIN + IF A /= IDENT_INT(3) THEN + FAILED ("INCORRECT VALUE FOR INNER HOMOGRAPH -10"); + END IF; + + IF TWO.A /= IDENT_INT(2) THEN + FAILED ("INCORRECT VALUE FOR OUTER HOMOGRAPH - 11"); + END IF; + + IF TWO.B /= IDENT_INT(2) THEN + FAILED ("INCORRECT VALUE FOR OUTER VARIABLE - 12"); + END IF; + + IF C /= IDENT_INT(3) THEN + FAILED ("INCORRECT VALUE FOR INNER VARIABLE - 13"); + END IF; + + IF X /= IDENT_INT(2) THEN + FAILED ("INCORRECT VALUE PASSED IN - 14"); + END IF; + + IF EQUAL(1,1) THEN + TWO.OBJ := IDENT_INT(4); + ELSE + TWO.OBJ := 1; + END IF; + END; + + IF OBJ /= IDENT_INT(4) THEN + FAILED ("INCORRECT VALUE PASSED OUT - 15"); + END IF; + END TWO; + + THREE: + DECLARE -- OVERLOADING OF FUNCTIONS. + + OBJ : INTEGER := 1; + FLO : FLOAT := 5.0; + + FUNCTION F IS NEW GEN_FUN (INTEGER, OBJ); + + FUNCTION F IS NEW GEN_FUN (FLOAT, FLO); + + BEGIN + DECLARE + F : FLOAT := 6.25; + BEGIN + THREE.OBJ := INTEGER(F); + END; + + IF OBJ /= IDENT_INT(6) THEN + FAILED ("INCORRECT VALUE RETURNED FROM FUNCTION - 20"); + END IF; + END THREE; + + RESULT; +END C83028A; diff --git a/gcc/testsuite/ada/acats/tests/c8/c83029a.ada b/gcc/testsuite/ada/acats/tests/c8/c83029a.ada new file mode 100644 index 000000000..1460a5317 --- /dev/null +++ b/gcc/testsuite/ada/acats/tests/c8/c83029a.ada @@ -0,0 +1,110 @@ +-- C83029A.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 A LOOP PARAMETER HIDES AN OUTER DECLARATION OF A +-- HOMOGRAPH. ALSO CHECK THAT THE OUTER DECLARATION IS DIRECTLY +-- VISIBLE IN BOTH DECLARATIVE REGIONS BEFORE THE DECLARATION OF +-- THE INNER HOMOGRAPH AND THE OUTER DECLARATION IS VISIBLE BY +-- SELECTION AFTER THE INNER HOMOGRAPH DECLARATION. + +-- HISTORY: +-- BCB 09/06/88 CREATED ORIGINAL TEST. + +WITH REPORT; USE REPORT; +PROCEDURE C83029A IS + + GENERIC + TYPE T IS PRIVATE; + X : T; + FUNCTION GEN_FUN RETURN T; + + FUNCTION GEN_FUN RETURN T IS + BEGIN + RETURN X; + END GEN_FUN; + +BEGIN + TEST ("C83029A", "CHECK THAT A LOOP PARAMETER HIDES AN OUTER " & + "DECLARATION OF A HOMOGRAPH"); + + ONE: + DECLARE + A : INTEGER := IDENT_INT(2); + B : INTEGER := A; + C : INTEGER; + + BEGIN -- ONE + + FOR A IN 1 .. 1 LOOP + C := A; + + IF A /= IDENT_INT(1) THEN + FAILED ("INCORRECT VALUE FOR INNER HOMOGRAPH - 1"); + END IF; + + IF ONE.A /= IDENT_INT(2) THEN + FAILED ("INCORRECT VALUE FOR OUTER HOMOGRAPH - 2"); + END IF; + + IF ONE.B /= IDENT_INT(2) THEN + FAILED ("INCORRECT VALUE FOR OUTER VARIABLE - 3"); + END IF; + + IF C /= IDENT_INT(1) THEN + FAILED ("INCORRECT VALUE FOR INNER VARIABLE - 4"); + END IF; + + IF EQUAL(1,1) THEN + ONE.A := A; + END IF; + END LOOP; + + IF A /= IDENT_INT(1) THEN + FAILED ("INCORRECT VALUE PASSED OUT - 6"); + END IF; + END ONE; + + TWO: + DECLARE -- OVERLOADING OF FUNCTIONS. + + OBJ : INTEGER := 1; + FLO : FLOAT := 5.0; + + FUNCTION F IS NEW GEN_FUN (INTEGER, OBJ); + + FUNCTION F IS NEW GEN_FUN (FLOAT, FLO); + + BEGIN + FOR F IN 1 .. 1 LOOP + OBJ := INTEGER(F); + END LOOP; + + IF OBJ /= IDENT_INT(1) THEN + FAILED ("INCORRECT VALUE RETURNED - 10"); + END IF; + END TWO; + + RESULT; +END C83029A; diff --git a/gcc/testsuite/ada/acats/tests/c8/c83030a.ada b/gcc/testsuite/ada/acats/tests/c8/c83030a.ada new file mode 100644 index 000000000..d992f7b28 --- /dev/null +++ b/gcc/testsuite/ada/acats/tests/c8/c83030a.ada @@ -0,0 +1,234 @@ +-- C83030A.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 WITHIN A GENERIC SUBPROGRAM BODY, NO SUBPROGRAM +-- DECLARED IN AN OUTER DECLARATIVE REGION IS HIDDEN (UNLESS THE +-- SUBPROGRAM IS A HOMOGRAPH OF THE GENERIC SUBPROGRAM). + +-- HISTORY: +-- TBN 08/03/88 CREATED ORIGINAL TEST. + +WITH REPORT; USE REPORT; +PROCEDURE C83030A IS + + GLOBAL : INTEGER := IDENT_INT(INTEGER'FIRST); + SWITCH1 : BOOLEAN := TRUE; + + PROCEDURE P IS + BEGIN + GLOBAL := IDENT_INT(1); + END P; + + PROCEDURE P (X : INTEGER) IS + BEGIN + GLOBAL := IDENT_INT(X); + END P; + +BEGIN + TEST ("C83030A", "CHECK THAT WITHIN A GENERIC SUBPROGRAM BODY, " & + "NO SUBPROGRAM DECLARED IN AN OUTER " & + "DECLARATIVE REGION IS HIDDEN " & + "(UNLESS THE SUBPROGRAM IS A HOMOGRAPH OF THE " & + "GENERIC SUBPROGRAM)"); + + ONE: + DECLARE + GENERIC + PROCEDURE P; + + PROCEDURE P IS + A : INTEGER := IDENT_INT(2); + BEGIN + IF SWITCH1 THEN + SWITCH1 := FALSE; + P; + IF GLOBAL /= IDENT_INT(3) THEN + FAILED ("INCORRECT VALUE FOR PROCEDURE CALL " & + "- 1"); + END IF; + END IF; + P(A); + IF GLOBAL /= IDENT_INT(2) THEN + FAILED ("INCORRECT VALUE FOR PROCEDURE CALL - 2"); + END IF; + GLOBAL := IDENT_INT(3); + END P; + + PROCEDURE NEW_P IS NEW P; + + BEGIN + IF GLOBAL /= IDENT_INT(INTEGER'FIRST) THEN + FAILED ("INCORRECT VALUE FOR START OF TEST ONE"); + END IF; + NEW_P; + IF GLOBAL /= IDENT_INT(3) THEN + FAILED ("INCORRECT VALUE FOR END OF TEST ONE"); + END IF; + END ONE; + + + TWO: + DECLARE + GLOBAL : INTEGER := IDENT_INT(INTEGER'FIRST); + SWITCH : BOOLEAN := TRUE; + + GENERIC + TYPE T IS (<>); + PROCEDURE P (X : T); + + PROCEDURE P (X : T) IS + A : T := T'FIRST; + BEGIN + IF SWITCH THEN + SWITCH := FALSE; + P (X); + IF GLOBAL /= IDENT_INT(2) THEN + FAILED ("INCORRECT VALUE FOR PROCEDURE CALL " & + "- 20"); + END IF; + GLOBAL := IDENT_INT(3); + ELSE + GLOBAL := IDENT_INT(2); + END IF; + END P; + + PROCEDURE NEW_P IS NEW P (INTEGER); + + BEGIN + IF GLOBAL /= IDENT_INT(INTEGER'FIRST) THEN + FAILED ("INCORRECT VALUE FOR START OF TEST TWO"); + END IF; + NEW_P (1); + IF GLOBAL /= IDENT_INT(3) THEN + FAILED ("INCORRECT VALUE FOR END OF TEST TWO"); + END IF; + END TWO; + + + THREE: + DECLARE + SWITCH : BOOLEAN := TRUE; + + FUNCTION F RETURN INTEGER IS + BEGIN + RETURN IDENT_INT(1); + END F; + + FUNCTION F RETURN BOOLEAN IS + BEGIN + RETURN IDENT_BOOL(FALSE); + END F; + + FUNCTION F (X : INTEGER) RETURN INTEGER IS + BEGIN + RETURN IDENT_INT(X); + END F; + + BEGIN + DECLARE + GENERIC + FUNCTION F RETURN INTEGER; + + FUNCTION F RETURN INTEGER IS + A : INTEGER := INTEGER'LAST; + BEGIN + IF SWITCH THEN + SWITCH := FALSE; + IF F /= IDENT_INT(3) THEN + FAILED ("INCORRECT VALUE FROM FUNCTION " & + "CALL - 30"); + END IF; + END IF; + IF F(A) /= IDENT_INT(INTEGER'LAST) THEN + FAILED ("INCORRECT VALUE FROM FUNCTION CALL " & + "- 31"); + END IF; + IF F THEN + FAILED ("INCORRECT VALUE FROM FUNCTION CALL " & + "- 32"); + END IF; + RETURN IDENT_INT(3); + END F; + + FUNCTION NEW_F IS NEW F; + + BEGIN + IF NEW_F /= IDENT_INT(3) THEN + FAILED ("INCORRECT VALUE FOR END OF TEST THREE"); + END IF; + END; + END THREE; + + + FOUR: + DECLARE + SWITCH : BOOLEAN := TRUE; + + FUNCTION F RETURN INTEGER IS + BEGIN + RETURN IDENT_INT(1); + END F; + + FUNCTION F RETURN BOOLEAN IS + BEGIN + RETURN IDENT_BOOL(FALSE); + END F; + + BEGIN + DECLARE + GENERIC + TYPE T IS (<>); + FUNCTION F RETURN T; + + FUNCTION F RETURN T IS + A : T := T'LAST; + BEGIN + IF SWITCH THEN + SWITCH := FALSE; + IF F /= T'LAST THEN + FAILED ("INCORRECT VALUE FROM FUNCTION " & + "CALL - 40"); + END IF; + RETURN T'FIRST; + ELSE + IF F THEN + FAILED ("INCORRECT VALUE FROM FUNCTION " & + "CALL - 41"); + END IF; + RETURN T'LAST; + END IF; + END F; + + FUNCTION NEW_F IS NEW F (INTEGER); + + BEGIN + IF NEW_F /= IDENT_INT(INTEGER'FIRST) THEN + FAILED ("INCORRECT VALUE FOR END OF TEST FOUR"); + END IF; + END; + END FOUR; + + RESULT; +END C83030A; diff --git a/gcc/testsuite/ada/acats/tests/c8/c83030c.ada b/gcc/testsuite/ada/acats/tests/c8/c83030c.ada new file mode 100644 index 000000000..914bd6465 --- /dev/null +++ b/gcc/testsuite/ada/acats/tests/c8/c83030c.ada @@ -0,0 +1,263 @@ +-- C83030C.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 WITHIN A GENERIC SUBPROGRAM BODY COMPILED AS A SUBUNIT +-- IN THE SAME COMPILATION, NON-HOMOGRAPH SUBPROGRAMS DECLARED +-- OUTSIDE THE GENERIC UNIT, AND HAVING THE SAME IDENTIFIER, ARE NOT +-- HIDDEN. + +-- HISTORY: +-- JET 10/17/88 CREATED ORIGINAL TEST. +-- BCB 10/03/90 ADDED "PRAGMA ELABORATE (REPORT);". + +WITH REPORT; USE REPORT; +PRAGMA ELABORATE (REPORT); +PACKAGE C83030C_DECL1 IS + GLOBAL : INTEGER := IDENT_INT(INTEGER'FIRST); + SWITCH : BOOLEAN := TRUE; + + PROCEDURE C83030C_PROC1; + PROCEDURE C83030C_PROC1 (X : INTEGER); + PROCEDURE C83030C_PROC2; + PROCEDURE C83030C_PROC2 (X : INTEGER); + FUNCTION C83030C_FUNC3 RETURN INTEGER; + FUNCTION C83030C_FUNC3 RETURN BOOLEAN; + FUNCTION C83030C_FUNC3 (X : INTEGER) RETURN INTEGER; + FUNCTION C83030C_FUNC4 RETURN INTEGER; + FUNCTION C83030C_FUNC4 RETURN BOOLEAN; +END C83030C_DECL1; + +WITH REPORT; USE REPORT; +WITH C83030C_DECL1; USE C83030C_DECL1; +PACKAGE C83030C_DECL2 IS + GENERIC + PROCEDURE C83030C_PROC1; + + GENERIC + TYPE T IS (<>); + PROCEDURE C83030C_PROC2 (X : T); + + GENERIC + FUNCTION C83030C_FUNC3 RETURN INTEGER; + + GENERIC + TYPE T IS (<>); + FUNCTION C83030C_FUNC4 RETURN T; +END C83030C_DECL2; + +WITH REPORT; USE REPORT; +PACKAGE BODY C83030C_DECL1 IS + PROCEDURE C83030C_PROC1 IS + BEGIN + GLOBAL := IDENT_INT(1); + END C83030C_PROC1; + + PROCEDURE C83030C_PROC1 (X : INTEGER) IS + BEGIN + GLOBAL := IDENT_INT(X); + END C83030C_PROC1; + + PROCEDURE C83030C_PROC2 IS + BEGIN + GLOBAL := IDENT_INT(1); + END C83030C_PROC2; + + PROCEDURE C83030C_PROC2 (X : INTEGER) IS + BEGIN + GLOBAL := IDENT_INT(X); + END C83030C_PROC2; + + FUNCTION C83030C_FUNC3 RETURN INTEGER IS + BEGIN + RETURN IDENT_INT(1); + END C83030C_FUNC3; + + FUNCTION C83030C_FUNC3 RETURN BOOLEAN IS + BEGIN + RETURN IDENT_BOOL(FALSE); + END C83030C_FUNC3; + + FUNCTION C83030C_FUNC3 (X : INTEGER) RETURN INTEGER IS + BEGIN + RETURN IDENT_INT(X); + END C83030C_FUNC3; + + FUNCTION C83030C_FUNC4 RETURN INTEGER IS + BEGIN + RETURN IDENT_INT(1); + END C83030C_FUNC4; + + FUNCTION C83030C_FUNC4 RETURN BOOLEAN IS + BEGIN + RETURN IDENT_BOOL(FALSE); + END C83030C_FUNC4; +END C83030C_DECL1; + +WITH REPORT; USE REPORT; +WITH C83030C_DECL1; USE C83030C_DECL1; +PACKAGE BODY C83030C_DECL2 IS + PROCEDURE C83030C_PROC1 IS SEPARATE; + PROCEDURE C83030C_PROC2 (X : T) IS SEPARATE; + FUNCTION C83030C_FUNC3 RETURN INTEGER IS SEPARATE; + FUNCTION C83030C_FUNC4 RETURN T IS SEPARATE; +END C83030C_DECL2; + +SEPARATE (C83030C_DECL2) +PROCEDURE C83030C_PROC1 IS + A : INTEGER := IDENT_INT(2); +BEGIN + IF SWITCH THEN + SWITCH := FALSE; + C83030C_PROC1; + IF GLOBAL /= IDENT_INT(3) THEN + FAILED ("INCORRECT VALUE FOR PROCEDURE CALL - 1"); + END IF; + END IF; + C83030C_PROC1(A); + IF GLOBAL /= IDENT_INT(2) THEN + FAILED ("INCORRECT VALUE FOR PROCEDURE CALL - 2"); + END IF; + GLOBAL := IDENT_INT(3); +END C83030C_PROC1; + +SEPARATE (C83030C_DECL2) +PROCEDURE C83030C_PROC2 (X : T) IS + A : T := T'FIRST; +BEGIN + IF SWITCH THEN + SWITCH := FALSE; + C83030C_PROC2 (X); + IF GLOBAL /= IDENT_INT(2) THEN + FAILED ("INCORRECT VALUE FOR PROCEDURE CALL - 20"); + END IF; + GLOBAL := IDENT_INT(3); + ELSE + GLOBAL := IDENT_INT(2); + END IF; +END C83030C_PROC2; + +SEPARATE (C83030C_DECL2) +FUNCTION C83030C_FUNC3 RETURN INTEGER IS + A : INTEGER := INTEGER'LAST; +BEGIN + IF SWITCH THEN + SWITCH := FALSE; + IF C83030C_FUNC3 /= IDENT_INT(3) THEN + FAILED ("INCORRECT VALUE FROM FUNCTION CALL - 30"); + END IF; + END IF; + IF C83030C_FUNC3(A) /= IDENT_INT(INTEGER'LAST) THEN + FAILED ("INCORRECT VALUE FROM FUNCTION CALL - 31"); + END IF; + IF C83030C_FUNC3 THEN + FAILED ("INCORRECT VALUE FROM FUNCTION CALL - 32"); + END IF; + RETURN IDENT_INT(3); +END C83030C_FUNC3; + +SEPARATE (C83030C_DECL2) +FUNCTION C83030C_FUNC4 RETURN T IS + A : T := T'LAST; +BEGIN + IF SWITCH THEN + SWITCH := FALSE; + IF C83030C_FUNC4 /= T'LAST THEN + FAILED ("INCORRECT VALUE FROM FUNCTION CALL - 40"); + END IF; + RETURN T'FIRST; + ELSE + IF C83030C_FUNC4 THEN + FAILED ("INCORRECT VALUE FROM FUNCTION CALL - 41"); + END IF; + RETURN T'LAST; + END IF; +END C83030C_FUNC4; + +WITH REPORT; USE REPORT; +WITH C83030C_DECL1, C83030C_DECL2; USE C83030C_DECL1, C83030C_DECL2; +PROCEDURE C83030C IS +BEGIN + TEST ("C83030C", "CHECK THAT WITHIN A GENERIC SUBPROGRAM BODY " & + "COMPILED AS A SUBUNIT IN THE SAME COMPILATION," & + " NON-HOMOGRAPH SUBPROGRAMS DECLARED OUTSIDE " & + "THE GENERIC UNIT, AND HAVING THE SAME " & + "IDENTIFIER, ARE NOT HIDDEN"); + + ONE: + DECLARE + PROCEDURE PROC1 IS NEW C83030C_DECL2.C83030C_PROC1; + BEGIN + IF GLOBAL /= IDENT_INT(INTEGER'FIRST) THEN + FAILED ("INCORRECT VALUE FOR START OF TEST ONE"); + END IF; + PROC1; + IF GLOBAL /= IDENT_INT(3) THEN + FAILED ("INCORRECT VALUE FOR END OF TEST ONE"); + END IF; + + GLOBAL := IDENT_INT(INTEGER'FIRST); + SWITCH := TRUE; + END ONE; + + TWO: + DECLARE + PROCEDURE PROC2 IS NEW C83030C_DECL2.C83030C_PROC2(INTEGER); + BEGIN + IF GLOBAL /= IDENT_INT(INTEGER'FIRST) THEN + FAILED ("INCORRECT VALUE FOR START OF TEST TWO"); + END IF; + PROC2 (1); + IF GLOBAL /= IDENT_INT(3) THEN + FAILED ("INCORRECT VALUE FOR END OF TEST TWO"); + END IF; + + SWITCH := TRUE; + END TWO; + + THREE: + DECLARE + FUNCTION FUNC3 IS NEW C83030C_DECL2.C83030C_FUNC3; + BEGIN + IF FUNC3 /= IDENT_INT(3) THEN + FAILED ("INCORRECT VALUE FOR END OF TEST THREE"); + END IF; + + SWITCH := TRUE; + END THREE; + + FOUR: + DECLARE + FUNCTION FUNC4 IS NEW C83030C_DECL2.C83030C_FUNC4 (INTEGER); + BEGIN + IF FUNC4 /= IDENT_INT(INTEGER'FIRST) THEN + FAILED ("INCORRECT VALUE FOR END OF TEST FOUR"); + END IF; + + GLOBAL := INTEGER'FIRST; + SWITCH := TRUE; + END FOUR; + + RESULT; +END C83030C; diff --git a/gcc/testsuite/ada/acats/tests/c8/c83031a.ada b/gcc/testsuite/ada/acats/tests/c8/c83031a.ada new file mode 100644 index 000000000..13b90bbc5 --- /dev/null +++ b/gcc/testsuite/ada/acats/tests/c8/c83031a.ada @@ -0,0 +1,163 @@ +-- C83031A.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 AN IMPLICIT DECLARATION OF A PREDEFINED OPERATOR OR +-- AN ENUMERATION LITERAL IS HIDDEN BY A SUBPROGRAM DECLARATION OR +-- A RENAMING DECLARATION WHICH DECLARES A HOMOGRAPH OF THE +-- OPERATOR OR LITERAL. + +-- HISTORY: +-- VCL 08/10/88 CREATED ORIGINAL TEST. +-- JRL 03/20/92 ELIMINATED REDUNDANT TESTING. + +WITH REPORT; USE REPORT; +PROCEDURE C83031A IS +BEGIN + TEST ("C83031A", "AN IMPLICIT DECLARATION OF A PREDEFINED " & + "OPERATOR OR AN ENUMERATION LITERAL IS HIDDEN " & + "BY A SUBPROGRAM DECLARATION OR A RENAMING " & + "DECLARATION WHICH DECLARES A HOMOGRAPH OF THE " & + "OPERATOR OR LITERAL"); + + DECLARE -- CHECK SUBPROGRAM DECLARATIONS OF OPERATORS + PACKAGE P IS + TYPE INT IS RANGE -20 .. 20; + + M : INT := 3 * INT(IDENT_INT(3)); + N : INT := 4 + INT(IDENT_INT(4)); + + FUNCTION "*" (LEFT, RIGHT : INT) RETURN INT; + TYPE INT2 IS PRIVATE; + FUNCTION "+" (LEFT, RIGHT : INT2) RETURN INT2; + PRIVATE + FUNCTION "+" (LEFT, RIGHT : INT) RETURN INT + RENAMES "/" ; + + TYPE INT2 IS RANGE -20 .. 20; + END P; + USE P; + + PACKAGE BODY P IS + FUNCTION "*" (LEFT, RIGHT : INT) RETURN INT IS + BEGIN + RETURN LEFT / RIGHT; + END "*"; + + FUNCTION "+" (LEFT, RIGHT : INT2) RETURN INT2 IS + BEGIN + RETURN LEFT - RIGHT; + END "+"; + + BEGIN + IF 2 * INT(IDENT_INT(2)) /= 1 THEN + FAILED ("INCORRECT VALUE RETURNED IN CALL TO " & + "EXPLICIT '*' OPERATOR - 1"); + END IF; + + IF N /= 8 THEN + FAILED ("INCORRECT INITIAL VALUE FOR N - 1"); + END IF; + N := 2 + 2; + IF N /= INT(IDENT_INT (1)) THEN + FAILED ("INCORRECT VALUE FOR N AFTER CALL TO " & + "EXPLICIT '+' OPERATOR - 1"); + END IF; + + DECLARE + Q : INT2 := 8 + 9; + BEGIN + IF Q /= -1 THEN + FAILED ("INCORRECT VALUE FOR Q"); + END IF; + END; + END P; + BEGIN + IF M /= 9 THEN + FAILED ("INCORRECT INITIAL VALUE FOR M - 2"); + END IF; + IF 2 * INT(IDENT_INT(2)) /= 1 THEN + FAILED ("INCORRECT VALUE RETURNED IN CALL TO " & + "EXPLICIT '*' OPERATOR - 2"); + END IF; + + N := 2 + 2; + IF N /= INT(IDENT_INT (4)) THEN + FAILED ("INCORRECT VALUE FOR N AFTER CALL TO " & + "IMPLICIT '+' OPERATOR - 2"); + END IF; + + END; + + DECLARE -- CHECK SUBPROGRAM DECLARATIONS OF ENUMERATION LITERALS. + + PACKAGE P1 IS + TYPE ENUM1 IS (E11, E12, E13); + TYPE PRIV1 IS PRIVATE; + FUNCTION E11 RETURN PRIV1; + PRIVATE + TYPE PRIV1 IS NEW ENUM1; + FUNCTION E12 RETURN PRIV1 RENAMES E13; + END P1; + USE P1; + + E13 : INTEGER := IDENT_INT (5); + + FUNCTION E12 RETURN ENUM1 RENAMES E11 ; + + FUNCTION CHECK (E: ENUM1) RETURN INTEGER IS + BEGIN + RETURN ENUM1'POS (E); + END CHECK; + + FUNCTION CHECK (E: INTEGER) RETURN INTEGER IS + BEGIN + RETURN INTEGER'POS (E); + END CHECK; + + PACKAGE BODY P1 IS + FUNCTION E11 RETURN PRIV1 IS + BEGIN + RETURN E13; + END E11; + BEGIN + IF PRIV1'(E11) /= E13 THEN + FAILED ("INCORRECT VALUE FOR E11"); + END IF; + + IF E12 /= PRIV1'LAST THEN + FAILED ("INCORRECT VALUE FOR E12 - 1"); + END IF; + END P1; + BEGIN + IF E12 /= ENUM1'FIRST THEN + FAILED ("INCORRECT VALUE FOR E12 - 2"); + END IF; + + IF CHECK (E13) /= 5 THEN + FAILED ("INCORRECT VALUE FOR E13"); + END IF; + END; + RESULT; +END C83031A; diff --git a/gcc/testsuite/ada/acats/tests/c8/c83031c.ada b/gcc/testsuite/ada/acats/tests/c8/c83031c.ada new file mode 100644 index 000000000..1327a2546 --- /dev/null +++ b/gcc/testsuite/ada/acats/tests/c8/c83031c.ada @@ -0,0 +1,101 @@ +-- C83031C.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 AN IMPLICIT DECLARATION OF A PREDEFINED OPERATOR OR +-- ENUMERATION LITERAL IS HIDDEN BY A GENERIC INSTANTIATION WHICH +-- DECLARES A HOMOGRAPH OF THE OPERATOR OR LITERAL. + +-- HISTORY: +-- BCB 09/15/88 CREATED ORIGINAL TEST. + +WITH REPORT; USE REPORT; +PROCEDURE C83031C IS + +BEGIN + TEST ("C83031C", "CHECK THAT AN IMPLICIT DECLARATION OF A " & + "PREDEFINED OPERATOR OR ENUMERATION LITERAL IS " & + "HIDDEN BY A GENERIC INSTANTIATION WHICH " & + "DECLARES A HOMOGRAPH OF THE OPERATOR OR " & + "LITERAL"); + + DECLARE -- CHECK SUBPROGRAM DECLARATIONS OF OPERATORS + PACKAGE P IS + TYPE INT IS RANGE -20 .. 20; + + GENERIC + TYPE X IS RANGE <>; + FUNCTION GEN_FUN (LEFT, RIGHT : X) RETURN X; + END P; + USE P; + + PACKAGE BODY P IS + FUNCTION GEN_FUN (LEFT, RIGHT : X) RETURN X IS + BEGIN + RETURN LEFT / RIGHT; + END GEN_FUN; + + FUNCTION "*" IS NEW GEN_FUN (INT); + BEGIN + IF 2 * INT(IDENT_INT(2)) /= 1 THEN + FAILED ("INCORRECT VALUE RETURNED IN CALL TO " & + "EXPLICIT '*' OPERATOR - 1"); + END IF; + END P; + BEGIN + NULL; + END; + + DECLARE -- CHECK SUBPROGRAM DECLARATIONS OF ENUMERATION LITERALS. + + PACKAGE P1 IS + TYPE ENUM1 IS (E11, E12, E13); + TYPE PRIV1 IS PRIVATE; + + GENERIC + TYPE X IS (<>); + FUNCTION GEN_FUN RETURN X; + PRIVATE + TYPE PRIV1 IS NEW ENUM1; + END P1; + USE P1; + + PACKAGE BODY P1 IS + FUNCTION GEN_FUN RETURN X IS + BEGIN + RETURN X'LAST; + END GEN_FUN; + + FUNCTION E11 IS NEW GEN_FUN (PRIV1); + BEGIN + IF PRIV1'(E11) /= E13 THEN + FAILED ("INCORRECT VALUE FOR E11"); + END IF; + END P1; + BEGIN + NULL; + END; + + RESULT; +END C83031C; diff --git a/gcc/testsuite/ada/acats/tests/c8/c83031e.ada b/gcc/testsuite/ada/acats/tests/c8/c83031e.ada new file mode 100644 index 000000000..7742678af --- /dev/null +++ b/gcc/testsuite/ada/acats/tests/c8/c83031e.ada @@ -0,0 +1,70 @@ +-- C83031E.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 AN IMPLICIT DECLARATION OF A PREDEFINED OPERATOR IS +-- HIDDEN BY A GENERIC FORMAL SUBPROGRAM DECLARATION WHICH DECLARES +-- A HOMOGRAPH OF THE OPERATOR. + +-- HISTORY: +-- BCB 09/19/88 CREATED ORIGINAL TEST. + +WITH REPORT; USE REPORT; + +PROCEDURE C83031E IS + +BEGIN + TEST ("C83031E", "CHECK THAT AN IMPLICIT DECLARATION OF A " & + "PREDEFINED OPERATOR IS HIDDEN BY A GENERIC " & + "FORMAL SUBPROGRAM DECLARATION WHICH DECLARES " & + "A HOMOGRAPH OF THE OPERATOR"); + + DECLARE -- CHECK SUBPROGRAM DECLARATIONS OF OPERATORS + TYPE INT IS RANGE -20 .. 20; + + GENERIC + WITH FUNCTION "*" (LEFT, RIGHT : INT) RETURN INT; + PACKAGE P IS + END P; + + PACKAGE BODY P IS + BEGIN + IF 2 * INT(IDENT_INT(2)) /= 1 THEN + FAILED ("INCORRECT VALUE RETURNED IN CALL TO " & + "EXPLICIT '*' OPERATOR - 1"); + END IF; + END P; + + FUNCTION MULT (X, Y : INT) RETURN INT IS + BEGIN + RETURN X / Y; + END MULT; + + PACKAGE NEW_P IS NEW P (MULT); + BEGIN + NULL; + END; + + RESULT; +END C83031E; diff --git a/gcc/testsuite/ada/acats/tests/c8/c83032a.ada b/gcc/testsuite/ada/acats/tests/c8/c83032a.ada new file mode 100644 index 000000000..b1920ee21 --- /dev/null +++ b/gcc/testsuite/ada/acats/tests/c8/c83032a.ada @@ -0,0 +1,111 @@ +-- C83032A.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 AN IMPLICIT DECLARATION OF A PREDEFINED OPERATOR OR +-- AN ENUMERATION LITERAL IS HIDDEN BY A DERIVED SUBPROGRAM +-- HOMOGRAPH. + +-- HISTORY: +-- VCL 08/10/88 CREATED ORIGINAL TEST. + +WITH REPORT; USE REPORT; +PROCEDURE C83032A IS +BEGIN + TEST ("C83032A", "AN IMPLICIT DECLARATION OF A PREDEFINED " & + "OPERATOR OR AN ENUMERATION LITERAL IS HIDDEN " & + "BY A DERIVED SUBPROGRAM HOMOGRAPH"); + + DECLARE -- CHECK PREDEFINED OPERATOR. + PACKAGE P IS + TYPE INT IS RANGE -20 .. 20; + FUNCTION "ABS" (X : INT) RETURN INT; + END P; + USE P; + + TYPE NINT IS NEW INT; + + I2 : NINT := -5; + + PACKAGE BODY P IS + I1 : NINT := 5; + + FUNCTION "ABS" (X : INT) RETURN INT IS + BEGIN + RETURN INT (- (ABS (INTEGER (X)))); + END "ABS"; + + BEGIN + IF "ABS"(I1) /= -5 THEN + FAILED ("INCORRECT VALUE FOR 'I1' AFTER CALL " & + "TO DERIVED ""ABS"" - 1"); + END IF; + + I1 := ABS (-10); + IF ABS I1 /= NINT(IDENT_INT (-10)) THEN + FAILED ("INCORRECT VALUE FOR 'I1' AFTER CALL " & + "TO DERIVED ""ABS"" - 2"); + END IF; + END P; + BEGIN + IF "ABS"(I2) /= -5 THEN + FAILED ("INCORRECT VALUE FOR 'I2' AFTER CALL " & + "TO DERIVED ""ABS"" - 1"); + END IF; + + I2 := ABS (10); + IF ABS I2 /= NINT (IDENT_INT (-10)) THEN + FAILED ("INCORRECT VALUE FOR 'I1' AFTER CALL " & + "TO DERIVED ""ABS"" - 2"); + END IF; + END; + + DECLARE -- CHECK ENUMERATION LITERALS. + + PACKAGE P1 IS + TYPE ENUM1 IS (E11, E12, E13); + TYPE PRIV1 IS PRIVATE; + FUNCTION E11 RETURN PRIV1; + PRIVATE + TYPE PRIV1 IS NEW ENUM1; + TYPE NPRIV1 IS NEW PRIV1; + END P1; + USE P1; + + PACKAGE BODY P1 IS + FUNCTION E11 RETURN PRIV1 IS + BEGIN + RETURN E13; + END E11; + BEGIN + IF NPRIV1'(E11) /= E13 THEN + FAILED ("INCORRECT VALUE FOR E11"); + END IF; + END P1; + + BEGIN + NULL; + END; + RESULT; +END C83032A; diff --git a/gcc/testsuite/ada/acats/tests/c8/c83033a.ada b/gcc/testsuite/ada/acats/tests/c8/c83033a.ada new file mode 100644 index 000000000..6cfca9326 --- /dev/null +++ b/gcc/testsuite/ada/acats/tests/c8/c83033a.ada @@ -0,0 +1,146 @@ +-- C83033A.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 AN IMPLICIT DECLARATION OF A BLOCK NAME, A LOOP NAME, +-- OR A STATEMENT LABEL HIDES THE DECLARATION OF AN ENUMERATION +-- LITERAL OR OF A DERIVED SUBPROGRAM DECLARED BY A DERIVED TYPE +-- DEFINITION. + +-- HISTORY: +-- DHH 09/21/88 CREATED ORIGINAL TEST. +-- WMC 03/25/92 REMOVED TEST REDUNDANCIES. + + +WITH REPORT; USE REPORT; +PROCEDURE C83033A IS + + PACKAGE BASE_P IS + TYPE A IS (RED, BLUE, YELO); + FUNCTION RED(T : INTEGER; X : A) RETURN A; + FUNCTION BLUE(T : INTEGER; X : A) RETURN A; + END BASE_P; + + PACKAGE BODY BASE_P IS + FUNCTION RED(T : INTEGER; X : A) RETURN A IS + BEGIN + IF EQUAL(T, T) THEN + RETURN X; + ELSE + RETURN YELO; + END IF; + END RED; + + FUNCTION BLUE(T : INTEGER; X : A) RETURN A IS + BEGIN + IF EQUAL(T, T) THEN + RETURN X; + ELSE + RETURN YELO; + END IF; + END BLUE; + + END BASE_P; +BEGIN + TEST ("C83033A", "CHECK THAT AN IMPLICIT DECLARATION OF A BLOCK " & + "NAME, A LOOP NAME, OR A STATEMENT LABEL HIDES " & + "THE DECLARATION OF AN ENUMERATION LITERAL OR " & + "OF A DERIVED SUBPROGRAM DECLARED BY A DERIVED " & + "TYPE DEFINITION"); + + B1: + DECLARE + TYPE STMT2 IS NEW BASE_P.A; + BEGIN + + DECLARE + C, D : STMT2; + BEGIN + C := C83033A.B1.RED(3, C83033A.B1.RED); + D := C83033A.B1.RED; + + GOTO RED; -- DEMONSTRATES USE OF STATEMENT LABEL. + FAILED("STATEMENT LABEL - 1"); + + <<RED>> IF C /= D THEN + FAILED("STATEMENT LABEL - 2"); + END IF; + END; + END B1; + + B2: + DECLARE + TYPE STMT2 IS NEW BASE_P.A; + BEGIN + + DECLARE + A : STMT2 := BLUE; + B : STMT2 := BLUE(3, BLUE); + BEGIN + + BLUE: + FOR I IN 1 .. 1 LOOP + IF A /= B THEN + FAILED("LOOP NAME - 1"); + END IF; + EXIT BLUE; -- DEMONSTRATES USE OF LOOP LABEL. + FAILED("LOOP NAME - 2"); + END LOOP BLUE; + END; + END B2; + + B4: + DECLARE + PACKAGE P IS + GLOBAL : INTEGER := 1; + TYPE ENUM IS (GREEN, BLUE); + TYPE PRIV IS PRIVATE; + FUNCTION GREEN RETURN PRIV; + PRIVATE + TYPE PRIV IS NEW ENUM; + END P; + + PACKAGE BODY P IS + FUNCTION GREEN RETURN PRIV IS + BEGIN + GLOBAL := GLOBAL + 1; + RETURN BLUE; + END GREEN; + BEGIN + NULL; + END P; + USE P; + BEGIN + GREEN: + DECLARE + COLOR : PRIV := C83033A.B4.P.GREEN; + BEGIN + IF GREEN.COLOR /= C83033A.B4.P.GREEN OR ELSE GLOBAL /= 3 THEN + FAILED("BLOCK NAME"); + END IF; + END GREEN; + END B4; + + RESULT; +END C83033A; diff --git a/gcc/testsuite/ada/acats/tests/c8/c83051a.ada b/gcc/testsuite/ada/acats/tests/c8/c83051a.ada new file mode 100644 index 000000000..0dc215260 --- /dev/null +++ b/gcc/testsuite/ada/acats/tests/c8/c83051a.ada @@ -0,0 +1,397 @@ +-- C83051A.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 DECLARATIONS IN THE VISIBLE PART OF A PACKAGE NESTED +-- WITHIN THE VISIBLE PART OF A PACKAGE ARE VISIBLE BY SELECTION +-- FROM OUTSIDE THE OUTERMOST PACKAGE. + +-- HISTORY: +-- GMT 09/07/88 CREATED ORIGINAL TEST. + +WITH REPORT; USE REPORT; + +PROCEDURE C83051A IS + +BEGIN + TEST ("C83051A", "CHECK THAT DECLARATIONS IN THE VISIBLE " & + "PART OF A PACKAGE NESTED WITHIN THE VISIBLE " & + "PART OF A PACKAGE ARE VISIBLE BY SELECTION " & + "FROM OUTSIDE THE OUTERMOST PACKAGE"); + A_BLOCK: + DECLARE + PACKAGE APACK IS + PACKAGE BPACK IS + TYPE T1 IS (RED,GREEN); + TYPE T2A IS ('A', 'B', 'C', 'D'); + TYPE T3 IS NEW BOOLEAN; + TYPE T4 IS NEW INTEGER RANGE -3 .. 8; + TYPE T5 IS DIGITS 5; + TYPE T67 IS DELTA 0.5 RANGE -2.0 .. 10.0; + TYPE T9A IS ARRAY (INTEGER RANGE <>) OF T3; + SUBTYPE T9B IS T9A (1..10); + TYPE T9C IS ACCESS T9B; + TYPE T10 IS PRIVATE; + V1 : T3 := FALSE; + ZERO : CONSTANT T4 := 0; + A_FLT : T5 := 3.0; + A_FIX : T67 := -1.0; + ARY : T9A(1..4) := (TRUE,TRUE,TRUE,FALSE); + P1 : T9C := NEW T9B'( 1..5 => T3'(TRUE), + 6..10 => T3'(FALSE) ); + C1 : CONSTANT T10; + + FUNCTION RET_T1 (X : T1) RETURN T1; + + FUNCTION RET_CHAR (X : CHARACTER) RETURN T10; + + GENERIC + PROCEDURE DO_NOTHING (X : IN OUT T3); + PRIVATE + TYPE T10 IS NEW CHARACTER; + C1 : CONSTANT T10 := 'J'; + END BPACK; + END APACK; + + PACKAGE BODY APACK IS + PACKAGE BODY BPACK IS + FUNCTION RET_T1 (X : T1) RETURN T1 IS + BEGIN + IF X = RED THEN + RETURN GREEN; + ELSE + RETURN RED; + END IF; + END RET_T1; + + FUNCTION RET_CHAR (X : CHARACTER) RETURN T10 IS + BEGIN + RETURN T10(X); + END RET_CHAR; + + PROCEDURE DO_NOTHING (X : IN OUT T3) IS + BEGIN + IF X = TRUE THEN + X := FALSE; + ELSE + X := TRUE; + END IF; + END DO_NOTHING; + END BPACK; + END APACK; + + PROCEDURE NEW_DO_NOTHING IS NEW APACK.BPACK.DO_NOTHING; + + BEGIN + + -- A1: VISIBILITY FOR UNOVERLOADED ENUMERATION LITERALS + + IF APACK.BPACK.">"(APACK.BPACK.RED, APACK.BPACK.GREEN) THEN + FAILED ("VISIBILITY FOR UNOVERLOADED ENUMERATION " & + "LITERAL BAD - A1"); + END IF; + + + -- A2: VISIBILITY FOR OVERLOADED + -- ENUMERATION CHARACTER LITERALS + + IF APACK.BPACK."<"(APACK.BPACK.T2A'(APACK.BPACK.'C'), + APACK.BPACK.T2A'(APACK.BPACK.'B')) THEN + FAILED ("VISIBILITY FOR OVERLOADED ENUMERATION " & + "LITERAL BAD - A2"); + END IF; + + + -- A3: VISIBILITY FOR A DERIVED BOOLEAN TYPE + + IF APACK.BPACK."<"(APACK.BPACK.T3'(APACK.BPACK.TRUE), + APACK.BPACK.FALSE) THEN + FAILED ("VISIBILITY FOR DERIVED BOOLEAN BAD - A3"); + END IF; + + + -- A4: VISIBILITY FOR AN INTEGER TYPE + + IF APACK.BPACK."/="(APACK.BPACK."MOD"(6,2),APACK.BPACK.ZERO) + THEN FAILED ("VISIBILITY FOR INTEGER TYPE BAD - A4"); + END IF; + + + -- A5: VISIBILITY FOR A FLOATING POINT TYPE + + IF APACK.BPACK.">"(APACK.BPACK.T5'(2.7),APACK.BPACK.A_FLT) + THEN FAILED ("VISIBILITY FOR FLOATING POINT BAD - A5"); + END IF; + + + -- A6: VISIBILITY FOR A FIXED POINT INVOLVING UNARY MINUS + + IF APACK.BPACK."<"(APACK.BPACK.A_FIX,APACK.BPACK.T67' + (APACK.BPACK."-"(1.5))) THEN + FAILED ("VISIBILITY FOR FIXED POINT WITH UNARY MINUS " & + "BAD - A6"); + END IF; + + + -- A7: VISIBILITY FOR A FIXED POINT DIVIDED BY INTEGER + + IF APACK.BPACK."/="(APACK.BPACK.T67(-0.5),APACK.BPACK."/" + (APACK.BPACK.A_FIX,2)) THEN + FAILED ("VISIBILITY FOR FIXED POINT DIVIDED BY " & + "INTEGER BAD - A7"); + END IF; + + + -- A8: VISIBILITY FOR ARRAY EQUALITY + + IF APACK.BPACK."/="(APACK.BPACK.ARY,(APACK.BPACK.T3(TRUE), + APACK.BPACK.T3(TRUE),APACK.BPACK.T3(TRUE), + APACK.BPACK.T3(FALSE))) THEN + FAILED ("VISIBILITY FOR ARRAY EQUALITY BAD - A8"); + END IF; + + + -- A9: VISIBILITY FOR ACCESS EQUALITY + + IF APACK.BPACK."/="(APACK.BPACK.P1(3), + APACK.BPACK.T3(IDENT_BOOL(TRUE))) + THEN FAILED ("VISIBILITY FOR ACCESS EQUALITY BAD - A9"); + END IF; + + + -- A10: VISIBILITY FOR PRIVATE TYPE + + IF APACK.BPACK."/="(APACK.BPACK.C1, + APACK.BPACK.RET_CHAR('J')) THEN + FAILED ("VISIBILITY FOR PRIVATE TYPE BAD - A10"); + END IF; + + + -- A11: VISIBILITY FOR DERIVED SUBPROGRAM + + IF APACK.BPACK."/="(APACK.BPACK.RET_T1(APACK.BPACK.RED), + APACK.BPACK.GREEN) THEN + FAILED ("VISIBILITY FOR DERIVED SUBPROGRAM BAD - A11"); + END IF; + + -- A12: VISIBILITY FOR GENERIC SUBPROGRAM + + NEW_DO_NOTHING (APACK.BPACK.V1); + + IF APACK.BPACK."/="(APACK.BPACK.V1,APACK.BPACK.T3(TRUE)) THEN + FAILED ("VISIBILITY FOR GENERIC SUBPROGRAM BAD - A12"); + END IF; + + END A_BLOCK; + + B_BLOCK: + DECLARE + GENERIC + TYPE T1 IS (<>); + PACKAGE GENPACK IS + PACKAGE APACK IS + PACKAGE BPACK IS + TYPE T1 IS (ORANGE,GREEN); + TYPE T2A IS ('E', 'F', 'G'); + TYPE T3 IS NEW BOOLEAN; + TYPE T4 IS NEW INTEGER RANGE -3 .. 8; + TYPE T5 IS DIGITS 5; + TYPE T67 IS DELTA 0.5 RANGE -3.0 .. 25.0; + TYPE T9A IS ARRAY (INTEGER RANGE <>) OF T3; + SUBTYPE T9B IS T9A (2 .. 8); + TYPE T9C IS ACCESS T9B; + TYPE T10 IS PRIVATE; + V1 : T3 := TRUE; + SIX : T4 := 6; + B_FLT : T5 := 4.0; + ARY : T9A(1..4) := (TRUE,FALSE,TRUE,FALSE); + P1 : T9C := NEW T9B'( 2..4 => T3'(FALSE), + 5..8 => T3'(TRUE)); + K1 : CONSTANT T10; + + FUNCTION RET_T1 (X : T1) RETURN T1; + + FUNCTION RET_CHAR (X : CHARACTER) RETURN T10; + + GENERIC + PROCEDURE DO_NOTHING (X : IN OUT T3); + PRIVATE + TYPE T10 IS NEW CHARACTER; + K1 : CONSTANT T10 := 'V'; + END BPACK; + END APACK; + END GENPACK; + + PACKAGE BODY GENPACK IS + PACKAGE BODY APACK IS + PACKAGE BODY BPACK IS + FUNCTION RET_T1 (X : T1) RETURN T1 IS + BEGIN + IF X = ORANGE THEN + RETURN GREEN; + ELSE + RETURN ORANGE; + END IF; + END RET_T1; + + FUNCTION RET_CHAR (X : CHARACTER) RETURN T10 IS + BEGIN + RETURN T10(X); + END RET_CHAR; + + PROCEDURE DO_NOTHING (X : IN OUT T3) IS + BEGIN + IF X = TRUE THEN + X := FALSE; + ELSE + X := TRUE; + END IF; + END DO_NOTHING; + END BPACK; + END APACK; + END GENPACK; + + PACKAGE MYPACK IS NEW GENPACK (T1 => INTEGER); + + PROCEDURE MY_DO_NOTHING IS NEW MYPACK.APACK.BPACK.DO_NOTHING; + + BEGIN + + -- B1: GENERIC INSTANCE OF UNOVERLOADED ENUMERATION LITERAL + + IF MYPACK.APACK.BPACK."<"(MYPACK.APACK.BPACK.GREEN, + MYPACK.APACK.BPACK.ORANGE) THEN + FAILED ("VISIBILITY FOR GENERIC INSTANCE OF " & + "UNOVERLOADED ENUMERATION LITERAL BAD - B1"); + END IF; + + + -- B2: GENERIC INSTANCE OF OVERLOADED ENUMERATION LITERAL + + IF MYPACK.APACK.BPACK.">"(MYPACK.APACK.BPACK.T2A'(MYPACK. + APACK.BPACK.'F'),MYPACK.APACK.BPACK.T2A'(MYPACK.APACK. + BPACK.'G')) THEN + FAILED ("VISIBILITY FOR GENERIC INSTANCE OF " & + "OVERLOADED ENUMERATION LITERAL BAD - B2"); + END IF; + + + -- B3: VISIBILITY FOR GENERIC INSTANCE OF DERIVED BOOLEAN + + IF MYPACK.APACK.BPACK."/="(MYPACK.APACK.BPACK."NOT"(MYPACK. + APACK.BPACK.T3'(MYPACK.APACK.BPACK.TRUE)),MYPACK.APACK. + BPACK.FALSE) THEN + FAILED ("VISIBILITY FOR GENERIC INSTANCE OF DERIVED " & + "BOOLEAN BAD - B3"); + END IF; + + + -- B4: VISIBILITY FOR GENERIC INSTANCE OF DERIVED INTEGER + + IF MYPACK.APACK.BPACK."/="(MYPACK.APACK.BPACK."MOD"(MYPACK. + APACK.BPACK.SIX,2),0) THEN + FAILED ("VISIBILITY FOR GENERIC INSTANCE OF INTEGER " & + "BAD - B4"); + END IF; + + + -- B5: VISIBILITY FOR GENERIC INSTANCE OF FLOATING POINT + + IF MYPACK.APACK.BPACK.">"(MYPACK.APACK.BPACK.T5'(1.9),MYPACK. + APACK.BPACK.B_FLT) THEN + FAILED ("VISIBILITY FOR GENERIC INSTANCE OF FLOATING " & + "POINT BAD - B5"); + END IF; + + + -- B6: VISIBILITY FOR GENERIC INSTANCE OF + -- FIXED POINT UNARY PLUS + + IF MYPACK.APACK.BPACK."<"(2.5,MYPACK.APACK.BPACK.T67'(MYPACK. + APACK.BPACK."+"(1.75))) THEN + FAILED ("VISIBILITY FOR GENERIC INSTANCE OF FIXED " & + "POINT UNARY PLUS BAD - B6"); + END IF; + + + -- B7: VISIBILITY FOR GENERIC INSTANCE OF + -- FIXED POINT DIVIDED BY INTEGER + + IF MYPACK.APACK.BPACK."/="(MYPACK.APACK.BPACK."/"(2.5,4), + 0.625) THEN + FAILED ("VISIBILITY FOR GENERIC INSTANCE OF FIXED " & + "POINT DIVIDED BY INTEGER BAD - B7"); + END IF; + + + -- B8: VISIBILITY FOR GENERIC INSTANCE OF ARRAY EQUALITY + + IF MYPACK.APACK.BPACK."/="(MYPACK.APACK.BPACK.ARY,(MYPACK. + APACK.BPACK.T3(TRUE),MYPACK.APACK.BPACK.T3(FALSE),MYPACK. + APACK.BPACK.T3(TRUE),MYPACK.APACK.BPACK.T3(FALSE))) THEN + FAILED ("VISIBILITY FOR GENERIC INSTANCE OF ARRAY " & + "EQUALITY BAD - B8"); + END IF; + + + -- B9: VISIBILITY FOR GENERIC INSTANCE OF ACCESS EQUALITY + + IF MYPACK.APACK.BPACK."/="(MYPACK.APACK.BPACK.P1(3),MYPACK. + APACK.BPACK.T3(IDENT_BOOL(FALSE))) THEN + FAILED ("VISIBILITY FOR GENERIC INSTANCE OF ACCESS " & + "EQUALITY BAD - B9"); + END IF; + + + -- B10: VISIBILITY FOR GENERIC INSTANCE OF PRIVATE EQUALITY + + IF MYPACK.APACK.BPACK."/="(MYPACK.APACK.BPACK.K1,MYPACK.APACK. + BPACK.RET_CHAR('V')) THEN + FAILED ("VISIBILITY FOR GENERIC INSTANCE OF PRIVATE " & + "EQUALITY BAD - B10"); + END IF; + + + -- B11: VISIBILITY FOR GENERIC INSTANCE OF DERIVED SUBPROGRAM + + IF MYPACK.APACK.BPACK."/="(MYPACK.APACK.BPACK.RET_T1(MYPACK. + APACK.BPACK.ORANGE),MYPACK.APACK.BPACK.GREEN) THEN + FAILED ("VISIBILITY FOR GENERIC INSTANCE OF DERIVED " & + "SUBPROGRAM BAD - B11"); + END IF; + + -- B12: VISIBILITY FOR GENERIC INSTANCE OF GENERIC SUBPROGRAM + + MY_DO_NOTHING (MYPACK.APACK.BPACK.V1); + + IF MYPACK.APACK.BPACK."/="(MYPACK.APACK.BPACK.V1, + MYPACK.APACK.BPACK.T3(FALSE)) THEN + FAILED ("VISIBILITY FOR GENERIC INSTANCE OF GENERIC " & + "SUBPROGRAM BAD - B12"); + END IF; + + END B_BLOCK; + + RESULT; +END C83051A; diff --git a/gcc/testsuite/ada/acats/tests/c8/c83b02a.ada b/gcc/testsuite/ada/acats/tests/c8/c83b02a.ada new file mode 100644 index 000000000..c982d3f9a --- /dev/null +++ b/gcc/testsuite/ada/acats/tests/c8/c83b02a.ada @@ -0,0 +1,79 @@ +-- C83B02A.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 LOOPS CAN HAVE IDENTICALLY NAMED PARAMETERS, +-- AND REFERENCES IN THE INNERMOST LOOP ARE ASSOCIATED WITH THE +-- INNERMOST PARAMETER, ETC. + + +-- RM 4 JUNE 1980 + + +WITH REPORT; +PROCEDURE C83B02A IS + + USE REPORT; + + I , J , K : INTEGER := 1 ; + +BEGIN + + TEST ( "C83B02A" , + "CHECK THAT NESTED LOOPS CAN HAVE IDENTICALLY NAMED" & + " PARAMETERS" ); + + -- I J K + FOR LOOP_PAR IN 2..2 LOOP + I := I * LOOP_PAR ; -- 2 1 1 + FOR LOOP_PAR IN 3..3 LOOP + I := I * LOOP_PAR ; -- 6 1 1 + FOR LOOP_PAR IN 5..5 LOOP + I := I * LOOP_PAR ; -- 30 1 1 + FOR SECOND_LOOP_PAR IN 7..7 LOOP + J := J * SECOND_LOOP_PAR ; -- 30 7 1 + FOR SECOND_LOOP_PAR IN 11..11 LOOP + J := J * SECOND_LOOP_PAR ;-- 30 77 1 + FOR SECOND_LOOP_PAR IN 13..13 LOOP + J := J * + SECOND_LOOP_PAR;-- 30 1001 1 + END LOOP; + K := K * LOOP_PAR ; -- 30 1001 5 + END LOOP; + K := K * LOOP_PAR ; -- 30 1001 25 + END LOOP; + K := K * LOOP_PAR ; -- 30 1001 125 + END LOOP; + K := K * LOOP_PAR ; -- 30 1001 375 + END LOOP; + K := K * LOOP_PAR ; -- 30 1001 750 + END LOOP; + + IF I /= 30 OR J /= 1001 OR K /= 750 THEN + FAILED ( "DID NOT ACCESS INNERMOST ENCLOSING IDENTICALLY " & + "NAMED LOOP PARAMETER IN NESTED LOOPS" ); + END IF; + + RESULT; + +END C83B02A; diff --git a/gcc/testsuite/ada/acats/tests/c8/c83b02b.ada b/gcc/testsuite/ada/acats/tests/c8/c83b02b.ada new file mode 100644 index 000000000..817647a94 --- /dev/null +++ b/gcc/testsuite/ada/acats/tests/c8/c83b02b.ada @@ -0,0 +1,112 @@ +-- C83B02B.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 NON-NESTED LOOPS CAN HAVE IDENTICALLY NAMED PARAMETERS, +-- AND REFERENCES IN EACH LOOP ARE ASSOCIATED WITH THAT LOOP'S +-- LOOP PARAMETER. (THIS IS PART B OF THE OBJECTIVE.) +-- CHECK ALSO THAT A LOOP PARAMETER CAN HAVE THE SAME IDENTIFIER +-- AS A VARIABLE DECLARED IN THE SCOPE IMMEDIATELY CONTAINING +-- THE LOOP. (THIS IS PART C OF THE OBJECTIVE.) + + + +-- RM 6 JUNE 1980 + + +WITH REPORT; +PROCEDURE C83B02B IS + + USE REPORT; + + I , J : INTEGER := 1 ; + +BEGIN + + TEST ( "C83B02B" , + "CHECK THAT NON-NESTED LOOPS CAN HAVE IDENTICALLY NAMED" & + " PARAMETERS" ); + + COMMENT ( "THE NAME MAY BE THE SAME AS THAT OF A VARIABLE" & + " KNOWN OUTSIDE THE LOOP" ); + + -- CHECK PART B OF THE OBJECTIVE + DECLARE + TYPE WEEKDAY IS ( MON , TUE , WED , THU , FRI ); + BEGIN + + FOR LOOP_PAR IN 3..3 LOOP + I := I * LOOP_PAR ; -- 3 + END LOOP; + + FOR LOOP_PAR IN FRI..FRI LOOP + I := I * WEEKDAY'POS(LOOP_PAR) ; -- 12 + END LOOP; + + FOR LOOP_PAR IN 7..7 LOOP + I := I * LOOP_PAR ; -- 84 + END LOOP; + + END; + + IF I /= 84 THEN + FAILED ("DID NOT ACCESS ENCLOSING IDENTICALLY NAMED " & + "LOOP PARAMETER IN NON-NESTED LOOPS"); + END IF; + + -- CHECK PART C OF THE OBJECTIVE + DECLARE + LOOP_PAR : INTEGER := 2 ; + BEGIN + + J := J * LOOP_PAR ; -- 2 + + FOR LOOP_PAR IN 3..3 LOOP + J := J * LOOP_PAR ; -- 6 + END LOOP; + + J := J * LOOP_PAR ; -- 12 + + FOR LOOP_PAR IN 5..5 LOOP + J := J * LOOP_PAR ; -- 60 + END LOOP; + + J := J * LOOP_PAR ; -- 120 + + FOR LOOP_PAR IN 7..7 LOOP + J := J * LOOP_PAR ; -- 840 + END LOOP; + + J := J * LOOP_PAR ; -- 1680 + + END; + + IF J /= 1680 THEN + FAILED ("DID NOT ACCESS IDENTICALLY NAMED LOOP PARAMETER " & + "INSIDE NON-NESTED LOOPS OR IDENTICALLY NAMED " & + "VARIABLE OUTSIDE LOOPS"); + END IF; + + RESULT; + +END C83B02B; diff --git a/gcc/testsuite/ada/acats/tests/c8/c83e02a.ada b/gcc/testsuite/ada/acats/tests/c8/c83e02a.ada new file mode 100644 index 000000000..a99c70b46 --- /dev/null +++ b/gcc/testsuite/ada/acats/tests/c8/c83e02a.ada @@ -0,0 +1,84 @@ +-- C83E02A.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 WITHIN THE BODY OF A SUBPROGRAM A FORMAL PARAMETER CAN BE +-- USED DIRECTLY IN A RANGE CONSTRAINT, A DISCRIMINANT CONSTRAINT, +-- AND AN INDEX CONSTRAINT. + +-- RM 8 JULY 1980 + + +WITH REPORT; +PROCEDURE C83E02A IS + + USE REPORT; + + Z : INTEGER := 0 ; + + PROCEDURE P1 ( A , B : INTEGER; C : IN OUT INTEGER ) IS + X : INTEGER RANGE A+1..1+B ; + BEGIN + X := A + 1 ; + C := X * B + B * X * A ; -- 4*3+3*4*3=48 + END ; + + PROCEDURE P2 ( A , B : INTEGER; C : IN OUT INTEGER ) IS + TYPE T (MAX : INTEGER) IS + RECORD + VALUE : INTEGER RANGE 1..3 ; + END RECORD ; + X : T(A); + BEGIN + X := ( MAX => 4 , VALUE => B ) ; -- ( 4 , 3 ) + C := 10*C + X.VALUE + 2 ; -- 10*48+3+2=485 + END ; + + FUNCTION F3 ( A , B : INTEGER ) RETURN INTEGER IS + TYPE TABLE IS ARRAY( A..B ) OF INTEGER ; + X : TABLE ; + Y : ARRAY( A..B ) OF INTEGER ; + BEGIN + X(A) := A ; -- 5 + Y(B) := B ; -- 6 + RETURN X(A)-Y(B)+4 ; -- 3 + END ; + + +BEGIN + + TEST( "C83E02A" , "CHECK THAT WITHIN THE BODY OF A SUBPROGRAM " & + " A FORMAL PARAMETER CAN BE USED DIRECTLY IN" & + " A RANGE CONSTRAINT, A DISCRIMINANT CONSTRAINT"& + ", AND AN INDEX CONSTRAINT" ) ; + + P1 ( 3 , 3 , Z ); -- Z BECOMES 48 + P2 ( 4 , F3( 5 , 6 ) , Z ); -- Z BECOMES 485 + + IF Z /= 485 THEN + FAILED( "ACCESSING ERROR OR COMPUTATION ERROR" ); + END IF; + + RESULT; + +END C83E02A; diff --git a/gcc/testsuite/ada/acats/tests/c8/c83e02b.ada b/gcc/testsuite/ada/acats/tests/c8/c83e02b.ada new file mode 100644 index 000000000..ba157672f --- /dev/null +++ b/gcc/testsuite/ada/acats/tests/c8/c83e02b.ada @@ -0,0 +1,65 @@ +-- C83E02B.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 WITHIN THE BODY OF A SUBPROGRAM A FORMAL PARAMETER CAN BE +-- USED IN AN EXCEPTION HANDLER. + +-- RM 10 JULY 1980 + + +WITH REPORT; +PROCEDURE C83E02B IS + + USE REPORT; + + Z : INTEGER := 0 ; + + PROCEDURE P1 ( A , B : INTEGER; C : IN OUT INTEGER ) IS + E : EXCEPTION ; + BEGIN + RAISE E ; + FAILED( "FAILURE TO RAISE E " ); + EXCEPTION + WHEN E => + C := A + B ; + WHEN OTHERS => + FAILED( "WRONG EXCEPTION RAISED" ); + END ; + + +BEGIN + + TEST( "C83E02B" , "CHECK THAT WITHIN THE BODY OF A SUBPROGRAM " & + " A FORMAL PARAMETER CAN BE USED IN AN EXCEP" & + "TION HANDLER" ) ; + + P1 ( 3 , 14 , Z ); + + IF Z /= 17 THEN + FAILED( "ACCESSING ERROR OR COMPUTATION ERROR" ); + END IF; + + RESULT; + +END C83E02B; diff --git a/gcc/testsuite/ada/acats/tests/c8/c83e03a.ada b/gcc/testsuite/ada/acats/tests/c8/c83e03a.ada new file mode 100644 index 000000000..0a46f34dd --- /dev/null +++ b/gcc/testsuite/ada/acats/tests/c8/c83e03a.ada @@ -0,0 +1,81 @@ +-- C83E03A.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 FORMAL PARAMETER IN A NAMED PARAMETER ASSOCIATION +-- IS NOT CONFUSED WITH AN ACTUAL PARAMETER IDENTIFIER HAVING THE +-- SAME SPELLING. + + +-- RM 23 JULY 1980 + + +WITH REPORT; +PROCEDURE C83E03A IS + + USE REPORT; + + P : INTEGER RANGE 1..23 := 17 ; + FLOW_INDEX : INTEGER := 0 ; + +BEGIN + + TEST( "C83E03A" , "CHECK THAT A FORMAL PARAMETER IN A NAMED" & + " PARAMETER ASSOCIATION IS NOT CONFUSED" & + " WITH AN ACTUAL PARAMETER HAVING THE" & + " SAME SPELLING" ); + + DECLARE + + PROCEDURE BUMP IS + BEGIN + FLOW_INDEX := FLOW_INDEX + 1 ; + END BUMP ; + + PROCEDURE P1 ( P : INTEGER ) IS + BEGIN + IF P = 17 THEN BUMP ; END IF ; + END ; + + FUNCTION F1 ( P : INTEGER ) RETURN INTEGER IS + BEGIN + RETURN P ; + END ; + + BEGIN + + P1 ( P ); + P1 ( P => P ); + + IF F1 ( P + 1 ) = 17 + 1 THEN BUMP ; END IF; + IF F1 ( P => P + 1 ) = 17 + 1 THEN BUMP ; END IF; + + END ; + + IF FLOW_INDEX /= 4 THEN + FAILED( "INCORRECT ACCESSING OR INCORRECT FLOW" ); + END IF; + + RESULT; + +END C83E03A; diff --git a/gcc/testsuite/ada/acats/tests/c8/c83f01a.ada b/gcc/testsuite/ada/acats/tests/c8/c83f01a.ada new file mode 100644 index 000000000..abf1d7499 --- /dev/null +++ b/gcc/testsuite/ada/acats/tests/c8/c83f01a.ada @@ -0,0 +1,109 @@ +-- C83F01A.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 INSIDE A PACKAGE BODY, AN ATTEMPT TO REFERENCE AN IDENTI- +-- FIER DECLARED IN THE CORRESPONDING PACKAGE SPECIFICATION +-- IS SUCCESSFUL, EVEN IF THE SAME IDENTIFIER IS DECLARED IN THE +-- ENVIRONMENT SURROUNDING THE PACKAGE BODY. + +-- NESTED PACKAGE BODIES ARE TESTED IN C83F01B , C83F01C , C83F01D + + +-- RM 05 AUGUST 1980 +-- JRK 13 NOV 1980 + + +WITH REPORT; +PROCEDURE C83F01A IS + + USE REPORT; + + X1 , X2 : INTEGER RANGE 1..23 := 17 ; + + TYPE T1 IS ( A , B , C) ; + + Z : T1 := A ; + + +BEGIN + + TEST( "C83F01A" , "CHECK THAT INSIDE A PACKAGE BODY, " & + "AN ATTEMPT TO REFERENCE AN IDENTIFIER " & + "DECLARED IN THE CORRESPONDING PACKAGE SPECI" & + "FICATION IS SUCCESSFUL EVEN IF THE SAME IDEN" & + "TIFIER IS DECLARED IN THE ENVIRONMENT SURROUND"& + "ING THE PACKAGE BODY" ) ; + + COMMENT( "NESTED PACKAGE BODIES ARE TESTED IN C83F01B , -C , -D"); + + + DECLARE + + + PACKAGE P IS + + X1 : BOOLEAN := FALSE ; + X2 : INTEGER RANGE 1..23 := 11 ; + Y1 : BOOLEAN := TRUE ; + Y2 : INTEGER := 5 ; + T1 : INTEGER := 6 ; + Z : INTEGER := 7 ; + + END P ; + + + Y1 , Y2 : INTEGER := 13 ; + + + PACKAGE BODY P IS + BEGIN + + X1 := X1 OR Y1 ; + Z := Z + T1 ; + Y2 := X2 * Y2 ; + + -- INCORRECT INTERPRETATIONS IN THE FIRST TWO + -- ASSIGNMENTS MANIFEST THEMSELVES AT + -- COMPILE TIME AS TYPE ERRORS. + + END P ; + + + BEGIN + + IF X1 /= 17 OR + Z /= A OR + Y2 /= 13 OR + NOT P.X1 OR + P.Z /= 13 OR + P.Y2 /= 55 + THEN FAILED( "INCORRECT ACCESSING" ); + END IF; + + END ; + + + RESULT; -- POSS. ERROR DURING ELABORATION OF P + +END C83F01A; diff --git a/gcc/testsuite/ada/acats/tests/c8/c83f01b.ada b/gcc/testsuite/ada/acats/tests/c8/c83f01b.ada new file mode 100644 index 000000000..3dca9fc9a --- /dev/null +++ b/gcc/testsuite/ada/acats/tests/c8/c83f01b.ada @@ -0,0 +1,129 @@ +-- C83F01B.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 INSIDE A PACKAGE BODY NESTED WITHIN ANOTHER PACKAGE BODY +-- AN ATTEMPT TO REFERENCE AN IDENTIFIER DECLARED IN THE +-- CORRESPONDING PACKAGE SPECIFICATION +-- IS SUCCESSFUL EVEN IF THE SAME IDENTIFIER IS DECLARED IN THE +-- OUTER PACKAGE (SPECIFICATION OR BODY) OR IN THE +-- ENVIRONMENT SURROUNDING THE OUTER PACKAGE BODY. + +-- INTERACTIONS WITH SEPARATE COMPILATION ARE TESTED IN C83F01C , +-- C83F01D . + + +-- RM 08 AUGUST 1980 +-- JRK 13 NOV 1980 + + +WITH REPORT; +PROCEDURE C83F01B IS + + USE REPORT; + + X1 , X2 : INTEGER RANGE 1..23 := 17 ; + + TYPE T1 IS ( A , B , C) ; + + Z : T1 := A ; + + +BEGIN + + TEST( "C83F01B" , "CHECK THAT INSIDE A NESTED PACKAGE BODY" & + " AN ATTEMPT TO REFERENCE AN IDENTIFIER" & + " DECLARED IN THE CORRESPONDING PACKAGE SPECI" & + "FICATION IS SUCCESSFUL EVEN IF THE SAME IDEN" & + "TIFIER IS DECLARED IN THE ENVIRONMENT SURROUND"& + "ING THE PACKAGE BODY" ) ; + + COMMENT("SEPARATELY COMPILED PACKAGES ARE TESTED IN C83F01C, -D"); + + + DECLARE + + + Y1 , Y2 : INTEGER := 100 ; + + + PACKAGE OUTER IS + + Y3 : INTEGER := 100 ; + + PACKAGE P IS + + X1 : BOOLEAN := FALSE ; + X2 : INTEGER RANGE 1..23 := 11 ; + Y1 , Y3 : BOOLEAN := TRUE ; + Y2 , Y4 : INTEGER := 5 ; + T1 : INTEGER := 6 ; + Z : INTEGER := 7 ; + + END P ; + + END OUTER ; + + + X2 : INTEGER := 100 ; + + + PACKAGE BODY OUTER IS + + Y4 : INTEGER := 200 ; + + PACKAGE BODY P IS + BEGIN + + X1 := NOT X1 AND Y1 AND Y3 ; + Z := Z + T1 ; + Y2 := X2 * Y2 ; + Y4 := X2 * Y4 ; + + -- INCORRECT INTERPRETATIONS IN THE FIRST TWO + -- ASSIGNMENTS MANIFEST THEMSELVES AT + -- COMPILE TIME AS TYPE ERRORS + + END P ; + + END OUTER ; + + + BEGIN + + IF X1 /= 17 OR + Z /= A OR + Y2 /= 100 OR + NOT OUTER.P.X1 OR + OUTER.P.Z /= 13 OR + OUTER.P.Y2 /= 55 OR + OUTER.P.Y4 /= 55 + THEN FAILED( "INCORRECT ACCESSING" ); + END IF; + + END ; + + + RESULT; -- POSSIBLE ERROR DURING ELABORATION OF P + +END C83F01B; diff --git a/gcc/testsuite/ada/acats/tests/c8/c83f01c0.ada b/gcc/testsuite/ada/acats/tests/c8/c83f01c0.ada new file mode 100644 index 000000000..9b8c2da17 --- /dev/null +++ b/gcc/testsuite/ada/acats/tests/c8/c83f01c0.ada @@ -0,0 +1,55 @@ +-- C83F01C0.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. +--* +-- SEPARATELY COMPILED PACKAGE FOR USE WITH C83F01C2M + +-- THIS PACKAGE IS A FULL-FLEDGED COMPILATION UNIT (AS OPPOSED TO +-- BEING A SUBUNIT; SUBUNITS ARE TESTED IN C83F01D0M , +-- C83F01D1 ). THE PRESENT FILE CONTAINS THE SPECIFICATION +-- OF THE PACKAGE. THE BODY IS IN FILE C83F01C1. + + +-- RM 13 AUGUST 1980 +-- RM 22 AUGUST 1980 +-- PWN 11/30/94 ADDED A PROCEDURE TO KEEP PACKAGE BODIES LEGAL. + + +PACKAGE C83F01C0 IS + + Y3 : INTEGER := 100 ; + + PACKAGE P IS + + X1 : BOOLEAN := FALSE ; + X2 : INTEGER RANGE 1..23 := 11 ; + Y1 , Y3 : BOOLEAN := TRUE ; + Y2 , Y4 : INTEGER := 5 ; + T1 : INTEGER := 6 ; + Z : INTEGER := 7 ; + + END P ; + + PROCEDURE REQUIRE_BODY; + +END C83F01C0 ; diff --git a/gcc/testsuite/ada/acats/tests/c8/c83f01c1.ada b/gcc/testsuite/ada/acats/tests/c8/c83f01c1.ada new file mode 100644 index 000000000..bd27d1671 --- /dev/null +++ b/gcc/testsuite/ada/acats/tests/c8/c83f01c1.ada @@ -0,0 +1,69 @@ +-- C83F01C1.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. +--* +-- SEPARATELY COMPILED PACKAGE FOR USE WITH C83F01C2M + +-- THIS PACKAGE IS A FULL-FLEDGED COMPILATION UNIT (AS OPPOSED TO +-- BEING A SUBUNIT; SUBUNITS ARE TESTED IN C83F01D0M , +-- C83F01D1 ). THE PRESENT FILE CONTAINS THE BODY OF THE PACKAGE. + +-- FOR THIS FILE, THE FILE NAME AND THE UNIT NAME ARE NOT THE SAME. + + +-- RM 13 AUGUST 1980 +-- RM 22 AUGUST 1980 +-- RM 28 AUGUST 1980 ('FAILED(.)' MOVED TO MAIN) +-- PWN 11/30/94 ADDED A PROCEDURE TO KEEP PACKAGE BODIES LEGAL. + + +PACKAGE BODY C83F01C0 IS + + Y4 : INTEGER := 200 ; + + PACKAGE BODY P IS + BEGIN + + X1 := NOT X1 AND Y1 AND Y3 ; + Z := Z + T1 ; + Y2 := X2 * Y2 ; + Y4 := X2 * Y4 ; + + -- INCORRECT INTERPRETATIONS IN THE FIRST TWO + -- ASSIGNMENTS MANIFEST THEMSELVES AT + -- COMPILE TIME AS TYPE ERRORS. + + -- ALL 4 ASSIGNMENTS ARE TESTED IN THE MAIN PROGRAM (RATHER + -- THAN HERE) TO PRECLUDE FALSE NEGATIVES (WHERE THE LACK + -- OF ELABORATION-TIME ERROR MESSAGES SIMPLY MEANS THAT THE + -- PACKAGE WAS NOT ELABORATED). + + + END P ; + + PROCEDURE REQUIRE_BODY IS + BEGIN + NULL; + END; + +END C83F01C0 ; diff --git a/gcc/testsuite/ada/acats/tests/c8/c83f01c2.ada b/gcc/testsuite/ada/acats/tests/c8/c83f01c2.ada new file mode 100644 index 000000000..dbce105fe --- /dev/null +++ b/gcc/testsuite/ada/acats/tests/c8/c83f01c2.ada @@ -0,0 +1,69 @@ +-- C83F01C2M.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. +--* +-- MAIN PROGRAM REQUIRING A SEPARATELY COMPILED PACKAGE +-- ( C83F01C0 ; SPECIFICATION IN C83F01C0.ADA , +-- BODY IN C83F01C1.ADA ) + +-- CHECK THAT INSIDE A PACKAGE BODY NESTED WITHIN A SEPARATELY COMPILED +-- PACKAGE BODY AN ATTEMPT TO REFERENCE AN IDENTIFIER DECLARED IN THE +-- CORRESPONDING PACKAGE SPECIFICATION +-- IS SUCCESSFUL EVEN IF THE SAME IDENTIFIER IS DECLARED IN THE +-- OUTER PACKAGE (SPECIFICATION OR BODY). + +-- CASE 1: PACKAGE IS A FULL-FLEDGED COMPILATION UNIT + + +-- RM 11 AUGUST 1980 +-- RM 22 AUGUST 1980 +-- RM 29 AUGUST 1980 (MOVED 'FAILED(.)' FROM C83F01C1.ADA TO HERE) + + +WITH REPORT , C83F01C0 ; +PROCEDURE C83F01C2M IS + + USE REPORT , C83F01C0 ; + +BEGIN + + TEST( "C83F01C" , "CHECK THAT INSIDE A PACKAGE BODY" & + " NESTED WITHIN A SEPARATELY" & + " COMPILED PACKAGE BODY LIBRARY UNIT," & + " AN ATTEMPT TO REFERENCE AN IDENTIFIER" & + " DECLARED IN THE CORRESPONDING PACKAGE SPECI" & + "FICATION IS SUCCESSFUL EVEN IF THE SAME IDEN" & + "TIFIER IS DECLARED IN THE OUTER PACKAGE" & + " (SPECIFICATION OR BODY)" ) ; + + IF NOT P.X1 OR + P.Z /= 13 OR + P.Y2 /= 55 OR + P.Y4 /= 55 + THEN FAILED( "INCORRECT ACCESSING" ); + END IF; + + RESULT ; + + +END C83F01C2M; diff --git a/gcc/testsuite/ada/acats/tests/c8/c83f01d0.ada b/gcc/testsuite/ada/acats/tests/c8/c83f01d0.ada new file mode 100644 index 000000000..c73f0bce9 --- /dev/null +++ b/gcc/testsuite/ada/acats/tests/c8/c83f01d0.ada @@ -0,0 +1,103 @@ +-- C83F01D0M.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. +--* +-- MAIN PROGRAM REQUIRING A SEPARATELY COMPILED PACKAGE BODY SUBUNIT +-- ( C83F01D1.ADA ) + +-- CHECK THAT INSIDE A PACKAGE BODY NESTED WITHIN A SEPARATELY COMPILED +-- PACKAGE BODY AN ATTEMPT TO REFERENCE AN IDENTIFIER DECLARED IN THE +-- CORRESPONDING PACKAGE SPECIFICATION +-- IS SUCCESSFUL EVEN IF THE SAME IDENTIFIER IS DECLARED IN THE +-- OUTER PACKAGE (SPECIFICATION OR BODY). + +-- CASE 2: PACKAGE BODY IS A COMPILATION SUBUNIT + + +-- RM 13 AUGUST 1980 +-- RM 29 AUGUST 1980 +-- JRK 13 NOV 1980 + + +WITH REPORT; +PROCEDURE C83F01D0M IS + + USE REPORT ; + + X1 , X2 : INTEGER RANGE 1..23 := 17 ; + Y1 : INTEGER := 157 ; + + TYPE T1 IS ( A , B , C) ; + + Z : T1 := A ; + + + PACKAGE C83F01D1 IS + + Y3 : INTEGER := 100 ; + + PACKAGE P IS + + X1 : BOOLEAN := FALSE ; + X2 : INTEGER RANGE 1..23 := 11 ; + Y1 , Y3 : BOOLEAN := TRUE ; + Y2 , Y4 : INTEGER := 5 ; + T1 : INTEGER := 23 ; + Z : INTEGER := 0 ; + + END P ; + + END C83F01D1 ; + + + Y2 : INTEGER := 200 ; + + + PACKAGE BODY C83F01D1 IS SEPARATE ; + + +BEGIN + + TEST( "C83F01D" , "CHECK THAT INSIDE A PACKAGE BODY" & + " NESTED WITHIN A SEPARATELY" & + " COMPILED PACKAGE BODY SUBUNIT," & + " AN ATTEMPT TO REFERENCE AN IDENTIFIER" & + " DECLARED IN THE CORRESPONDING PACKAGE SPECI" & + "FICATION IS SUCCESSFUL EVEN IF THE SAME IDEN" & + "TIFIER IS DECLARED IN THE OUTER PACKAGE" & + " (SPECIFICATION OR BODY)" ) ; + + IF X1 /= 17 OR + Z /= A OR + Y2 /= 200 OR + NOT C83F01D1.P.X1 OR + C83F01D1.P.Z /= 23 OR + C83F01D1.P.Y2 /= 55 OR + C83F01D1.P.Y4 /= 55 + THEN FAILED( "INCORRECT ACCESSING" ); + END IF; + + RESULT ; + + +END C83F01D0M; diff --git a/gcc/testsuite/ada/acats/tests/c8/c83f01d1.ada b/gcc/testsuite/ada/acats/tests/c8/c83f01d1.ada new file mode 100644 index 000000000..fb0d9f508 --- /dev/null +++ b/gcc/testsuite/ada/acats/tests/c8/c83f01d1.ada @@ -0,0 +1,57 @@ +-- C83F01D1.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. +--* +-- SEPARATELY COMPILED PACKAGE BODY FOR USE WITH C83F01D0M + + +-- RM 13 AUGUST 1980 +-- RM 29 AUGUST 1980 + + + +SEPARATE (C83F01D0M) +PACKAGE BODY C83F01D1 IS + + Y4 : INTEGER := 200 ; + + PACKAGE BODY P IS + BEGIN + + X1 := NOT X1 AND Y1 AND Y3 ; + Z := Z + T1 ; + Y2 := X2 * Y2 ; + Y4 := X2 * Y4 ; + + -- ALL 4 ASSIGNMENTS ARE TESTED IN THE MAIN PROGRAM (RATHER + -- THAN HERE) TO PRECLUDE FALSE NEGATIVES (WHERE THE LACK + -- OF ELABORATION-TIME ERROR MESSAGES SIMPLY MEANS THAT THE + -- PACKAGE WAS NOT ELABORATED). + + -- INCORRECT INTERPRETATIONS IN THE FIRST TWO + -- ASSIGNMENTS MANIFEST THEMSELVES AT + -- COMPILE TIME AS TYPE ERRORS. + + END P ; + +END C83F01D1 ; diff --git a/gcc/testsuite/ada/acats/tests/c8/c83f03a.ada b/gcc/testsuite/ada/acats/tests/c8/c83f03a.ada new file mode 100644 index 000000000..a24f03863 --- /dev/null +++ b/gcc/testsuite/ada/acats/tests/c8/c83f03a.ada @@ -0,0 +1,113 @@ +-- C83F03A.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 INSIDE A PACKAGE BODY AN ATTEMPT TO PLACE AND REFERENCE +-- A LABEL IS SUCCESSFUL EVEN IF ITS IDENTIFIER IS DECLARED IN THE +-- ENVIRONMENT SURROUNDING THE PACKAGE BODY. + +-- NESTED PACKAGE BODIES ARE TESTED IN C83F03B , C83F03C , C83F03D + + +-- RM 03 SEPTEMBER 1980 + + +WITH REPORT; +PROCEDURE C83F03A IS + + USE REPORT; + + X1 , X2 : INTEGER RANGE 1..23 := 17 ; + + TYPE T1 IS ( A , B , C) ; + + Z : T1 := A ; + + FLOW_INDEX : INTEGER := 0 ; + +BEGIN + + TEST( "C83F03A" , "CHECK THAT INSIDE A PACKAGE BODY " & + " AN ATTEMPT TO PLACE AND REFERENCE A LABEL" & + " IS SUCCESSFUL EVEN IF ITS IDEN" & + "TIFIER IS DECLARED IN THE ENVIRONMENT SURROUND"& + "ING THE PACKAGE BODY" ) ; + + + DECLARE + + + Y1 , Y2 : INTEGER := 13 ; + + + PROCEDURE BUMP IS + BEGIN + FLOW_INDEX := FLOW_INDEX + 1 ; + END BUMP ; + + + PACKAGE P IS + + AA : BOOLEAN := FALSE ; + + END P ; + + + PACKAGE BODY P IS + BEGIN + + GOTO X1 ; + + BUMP ; + BUMP ; + + <<X1>> BUMP ; GOTO X2 ; + BUMP ; + <<T1>> BUMP ; GOTO Z ; + BUMP ; + <<Y1>> BUMP ; GOTO Y2 ; + BUMP ; + <<Y2>> BUMP ; GOTO T1 ; + BUMP ; + <<X2>> BUMP ; GOTO Y1 ; + BUMP ; + <<Z >> BUMP ; GOTO ENDING ; + BUMP ; + + << ENDING >> NULL; + + END P ; + + + BEGIN + + IF FLOW_INDEX /= 6 + THEN FAILED( "INCORRECT FLOW OF CONTROL" ); + END IF; + + END ; + + + RESULT; -- POSS. ERROR DURING ELABORATION OF P + +END C83F03A; diff --git a/gcc/testsuite/ada/acats/tests/c8/c83f03b.ada b/gcc/testsuite/ada/acats/tests/c8/c83f03b.ada new file mode 100644 index 000000000..4b5afea76 --- /dev/null +++ b/gcc/testsuite/ada/acats/tests/c8/c83f03b.ada @@ -0,0 +1,157 @@ +-- C83F03B.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 A PACKAGE BODY IS NESTED INSIDE ANOTHER PACKAGE BODY +-- THE INNER PACKAGE BODY CAN CONTAIN A LABEL IDENTIFIER IDENTICAL +-- TO A LABEL IDENTIFIER IN THE OUTER PACKAGE BODY, TO AN IDENTI- +-- FIER DECLARED IN THE OUTER PACKAGE BODY OR IN ITS SPECIFICATION, +-- OR TO A LABEL IDENTIFIER OR OTHER IDENTIFIER IN THE +-- ENVIRONMENT SURROUNDING THE OUTER PACKAGE BODY. + + +-- INTERACTIONS WITH SEPARATE COMPILATION ARE TESTED IN C83F03C , +-- C83F03D . + + +-- RM 04 SEPTEMBER 1980 + + +WITH REPORT; +PROCEDURE C83F03B IS + + USE REPORT; + + X1 , X2 : INTEGER RANGE 1..23 := 17 ; + + TYPE T1 IS ( A , B , C) ; + + Z : T1 := A ; + + FLOW_INDEX : INTEGER := 0 ; + +BEGIN + + TEST( "C83F03B" , "CHECK THAT IF A PACKAGE BODY IS NESTED" & + " INSIDE ANOTHER PACKAGE BODY, THE INNER" & + " PACKAGE BODY CAN CONTAIN A LABEL IDENTIFIER" & + " IDENTICAL TO A LABEL IDENTIFIER IN THE OUTER" & + " PACKAGE BODY, TO AN IDENTIFIER DECLARED IN" & + " THE OUTER PACKAGE BODY OR IN ITS SPECIFICA" & + "TION, OR TO A LABEL IDENTIFIER OR OTHER" & + " IDENTIFIER IN THE ENVIRONMENT SURROUNDING" & + " THE OUTER PACKAGE BODY" ) ; + + + DECLARE + + + Y1 , Y2 : INTEGER := 100 ; + + X2 : INTEGER := 100 ; + + + PROCEDURE BUMP IS + BEGIN + FLOW_INDEX := FLOW_INDEX + 1 ; + END BUMP ; + + + PACKAGE OUTER IS + + Y3 : INTEGER := 100 ; + + TYPE T3 IS ( D , E , F ) ; + + PACKAGE P IS + AA : BOOLEAN := FALSE ; + END P ; + + END OUTER ; + + + PACKAGE BODY OUTER IS + + Y4 : INTEGER := 200 ; + + TYPE T4 IS ( G , H , I ) ; + + PACKAGE BODY P IS + BEGIN + + + GOTO X1 ; + + BUMP ; + BUMP ; + + <<X1>> BUMP ; GOTO X2 ; + BUMP ; + <<T1>> BUMP ; GOTO Z ; + BUMP ; + <<Y1>> BUMP ; GOTO Y2 ; + BUMP ; + <<Y2>> BUMP ; GOTO T1 ; + BUMP ; + <<X2>> BUMP ; GOTO Y1 ; + BUMP ; + <<Z >> BUMP ; GOTO T3 ; + BUMP ; + <<T3>> BUMP ; GOTO T4 ; + BUMP ; + <<LABEL_IN_OUTER>> BUMP ; GOTO LABEL_IN_MAIN ; + BUMP ; + <<Y3>> BUMP ; GOTO Y4 ; + BUMP ; + <<Y4>> BUMP ; GOTO LABEL_IN_OUTER ; + BUMP ; + <<T4>> BUMP ; GOTO Y3 ; + BUMP ; + <<LABEL_IN_MAIN >> BUMP ; GOTO ENDING ; + BUMP ; + + << ENDING >> NULL; + + END P ; + + BEGIN + + << LABEL_IN_OUTER >> NULL ; + + END OUTER ; + + + BEGIN + + << LABEL_IN_MAIN >> + + IF FLOW_INDEX /= 12 + THEN FAILED( "INCORRECT FLOW OF CONTROL" ); + END IF; + + END ; + + + RESULT; -- POSS. ERROR DURING ELABORATION OF P + +END C83F03B; diff --git a/gcc/testsuite/ada/acats/tests/c8/c83f03c0.ada b/gcc/testsuite/ada/acats/tests/c8/c83f03c0.ada new file mode 100644 index 000000000..15962eb50 --- /dev/null +++ b/gcc/testsuite/ada/acats/tests/c8/c83f03c0.ada @@ -0,0 +1,53 @@ +-- C83F03C0.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. +--* +-- SEPARATELY COMPILED PACKAGE FOR USE WITH C83F03C2M + +-- THIS PACKAGE IS A FULL-FLEDGED COMPILATION UNIT (AS OPPOSED TO +-- BEING A SUBUNIT; SUBUNITS ARE TESTED IN C83F03D0M , +-- C83F03D1 ). THE PRESENT FILE CONTAINS THE SPECIFICATION +-- OF THE PACKAGE. THE PACKAGE BODY IS IN C83F03C1.ADA . + + +-- RM 04 SEPTEMBER 1980 +-- PWN 11/30/94 ADDED A PROCEDURE TO KEEP PACKAGE BODIES LEGAL. + + +PACKAGE C83F03C0 IS + + Y3 : INTEGER := 100 ; + + TYPE T3 IS ( D , E , F ) ; + + FLOW_INDEX : INTEGER := 0 ; + + PROCEDURE REQUIRE_BODY; + + PACKAGE P IS + + AA : BOOLEAN := FALSE ; + + END P ; + +END C83F03C0 ; diff --git a/gcc/testsuite/ada/acats/tests/c8/c83f03c1.ada b/gcc/testsuite/ada/acats/tests/c8/c83f03c1.ada new file mode 100644 index 000000000..fa4dbf037 --- /dev/null +++ b/gcc/testsuite/ada/acats/tests/c8/c83f03c1.ada @@ -0,0 +1,81 @@ +-- C83F03C1.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. +--* +-- SEPARATELY COMPILED PACKAGE FOR USE WITH C83F03C2M + +-- THIS PACKAGE IS A FULL-FLEDGED COMPILATION UNIT (AS OPPOSED TO +-- BEING A SUBUNIT; SUBUNITS ARE TESTED IN C83F03D0M , +-- C83F03D1 ). THE PRESENT FILE CONTAINS THE BODY OF THE PACKAGE. + +-- FOR THIS FILE, THE FILE NAME AND THE UNIT NAME ARE NOT THE SAME. + + +-- RM 05 SEPTEMBER 1980 +-- PWN 11/30/94 ADDED A PROCEDURE TO KEEP PACKAGE BODIES LEGAL. + + +PACKAGE BODY C83F03C0 IS + + Y4 : INTEGER := 200 ; + + TYPE T4 IS ( G , H , I ) ; + + PROCEDURE BUMP IS + BEGIN + FLOW_INDEX := FLOW_INDEX + 1 ; + END BUMP ; + + PROCEDURE REQUIRE_BODY IS + BEGIN + NULL; + END; + + PACKAGE BODY P IS + BEGIN + + GOTO T3 ; + + BUMP ; + BUMP ; + + <<T3>> BUMP ; GOTO T4 ; + BUMP ; + <<LABEL_IN_OUTER>> BUMP ; GOTO ENDING ; + BUMP ; + <<Y3>> BUMP ; GOTO Y4 ; + BUMP ; + <<Y4>> BUMP ; GOTO LABEL_IN_OUTER ; + BUMP ; + <<T4>> BUMP ; GOTO Y3 ; + BUMP ; + + << ENDING >> NULL; + + END P ; + +BEGIN + + << LABEL_IN_OUTER >> NULL ; + +END C83F03C0 ; diff --git a/gcc/testsuite/ada/acats/tests/c8/c83f03c2.ada b/gcc/testsuite/ada/acats/tests/c8/c83f03c2.ada new file mode 100644 index 000000000..978f834bf --- /dev/null +++ b/gcc/testsuite/ada/acats/tests/c8/c83f03c2.ada @@ -0,0 +1,64 @@ +-- C83F03C2M.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. +--* +-- MAIN PROGRAM REQUIRING A SEPARATELY COMPILED PACKAGE +-- ( C83F03C0 ; SPECIFICATION IN C83F03C0.ADA , +-- BODY IN C83F03C1.ADA ) + +-- CHECK THAT IF A PACKAGE BODY IS NESTED INSIDE A SEPARATELY COMPILED +-- PACKAGE BODY +-- THE INNER PACKAGE BODY CAN CONTAIN A LABEL IDENTIFIER IDENTICAL +-- TO A LABEL IDENTIFIER IN THE OUTER PACKAGE BODY OR TO AN IDENTI- +-- FIER DECLARED IN THE OUTER PACKAGE BODY OR IN ITS SPECIFICATION. + +-- CASE 1: PACKAGE IS A FULL-FLEDGED COMPILATION UNIT + + +-- RM 05 SEPTEMBER 1980 + + +WITH REPORT , C83F03C0 ; +PROCEDURE C83F03C2M IS + + USE REPORT , C83F03C0 ; + +BEGIN + + TEST( "C83F03C" , "CHECK THAT IF A PACKAGE BODY IS NESTED" & + " INSIDE A SEPARATELY COMPILED PACKAGE BODY" & + " LIBRARY UNIT, THE INNER" & + " PACKAGE BODY CAN CONTAIN A LABEL IDENTIFIER" & + " IDENTICAL TO A LABEL IDENTIFIER IN THE OUTER" & + " PACKAGE BODY OR TO AN IDENTIFIER DECLARED IN" & + " THE OUTER PACKAGE BODY OR IN ITS SPECIFICA" & + "TION" ) ; + + IF FLOW_INDEX /= 5 + THEN FAILED( "INCORRECT FLOW OF CONTROL" ); + END IF; + + RESULT; -- POSS. ERROR DURING ELABORATION OF P + + +END C83F03C2M; diff --git a/gcc/testsuite/ada/acats/tests/c8/c83f03d0.ada b/gcc/testsuite/ada/acats/tests/c8/c83f03d0.ada new file mode 100644 index 000000000..e2ecd76fd --- /dev/null +++ b/gcc/testsuite/ada/acats/tests/c8/c83f03d0.ada @@ -0,0 +1,89 @@ +-- C83F03D0M.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. +--* +-- MAIN PROGRAM REQUIRING A SEPARATELY COMPILED PACKAGE BODY SUBUNIT +-- ( C83F03D1.ADA ) + +-- CHECK THAT IF A PACKAGE BODY IS NESTED INSIDE A SEPARATELY COMPILED +-- PACKAGE BODY +-- THE INNER PACKAGE BODY CAN CONTAIN A LABEL IDENTIFIER IDENTICAL +-- TO A LABEL IDENTIFIER IN THE OUTER PACKAGE BODY OR TO AN IDENTI- +-- FIER DECLARED IN THE OUTER PACKAGE BODY OR IN ITS SPECIFICATION +-- OR IN ITS ENVIRONMENT. + +-- CASE 2: PACKAGE BODY IS A COMPILATION SUBUNIT + + +-- RM 08 SEPTEMBER 1980 +-- JRK 14 NOVEMBER 1980 + + +WITH REPORT; +PROCEDURE C83F03D0M IS + + USE REPORT ; + + X1 : INTEGER := 17 ; + + TYPE T1 IS ( A, B, C ) ; + + Z : T1 := A ; + + FLOW_INDEX : INTEGER := 0 ; + + + PACKAGE C83F03D1 IS + + Y3 : INTEGER := 100 ; + + TYPE T3 IS ( D , E , F ) ; + + PACKAGE P IS + AA : BOOLEAN := FALSE ; + END P ; + + END C83F03D1 ; + + + Y1 : INTEGER := 100 ; + + + PACKAGE BODY C83F03D1 IS SEPARATE ; + + +BEGIN + + TEST( "C83F03D" , "CHECK THE RECOGNITION OF LABELS IN NESTED" & + " PACKAGES SEPARATELY COMPILED AS SUBUNITS" ); + + << LABEL_IN_MAIN >> + + IF FLOW_INDEX /= 10 + THEN FAILED( "INCORRECT FLOW OF CONTROL" ); + END IF; + + RESULT; -- POSS. ERROR DURING ELABORATION OF P + + +END C83F03D0M; diff --git a/gcc/testsuite/ada/acats/tests/c8/c83f03d1.ada b/gcc/testsuite/ada/acats/tests/c8/c83f03d1.ada new file mode 100644 index 000000000..aac2cf939 --- /dev/null +++ b/gcc/testsuite/ada/acats/tests/c8/c83f03d1.ada @@ -0,0 +1,82 @@ +-- C83F03D1.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. +--* +-- SEPARATELY COMPILED PACKAGE BODY FOR USE WITH C83F03D0M + + +-- RM 08 SEPTEMBER 1980 +-- JRK 14 NOVEMBER 1980 + + + +SEPARATE (C83F03D0M) +PACKAGE BODY C83F03D1 IS + + Y4 : INTEGER := 200 ; + + TYPE T4 IS ( G , H , I ) ; + + PROCEDURE BUMP IS + BEGIN + FLOW_INDEX := FLOW_INDEX + 1 ; + END BUMP ; + + PACKAGE BODY P IS + BEGIN + + GOTO X1 ; + + BUMP ; + BUMP ; + + <<LABEL_IN_MAIN>> BUMP ; GOTO T3 ; + BUMP ; + <<T1>> BUMP ; GOTO Z ; + BUMP ; + <<Y1>> BUMP ; GOTO LABEL_IN_MAIN ; + BUMP ; + <<X1>> BUMP ; GOTO T1 ; + BUMP ; + <<Z>> BUMP ; GOTO Y1 ; + BUMP ; + <<T3>> BUMP ; GOTO T4 ; + BUMP ; + <<LABEL_IN_OUTER>> BUMP ; GOTO ENDING ; + BUMP ; + <<Y3>> BUMP ; GOTO Y4 ; + BUMP ; + <<Y4>> BUMP ; GOTO LABEL_IN_OUTER ; + BUMP ; + <<T4>> BUMP ; GOTO Y3 ; + BUMP ; + + << ENDING >> NULL; + + END P ; + +BEGIN + + << LABEL_IN_OUTER >> NULL ; + +END C83F03D1 ; diff --git a/gcc/testsuite/ada/acats/tests/c8/c840001.a b/gcc/testsuite/ada/acats/tests/c8/c840001.a new file mode 100644 index 000000000..2a1df1640 --- /dev/null +++ b/gcc/testsuite/ada/acats/tests/c8/c840001.a @@ -0,0 +1,257 @@ +-- C840001.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 the type determined by the subtype mark of a use type +-- clause, the declaration of each primitive operator is use-visible +-- within the scope of the clause, even if explicit operators with the +-- same names as the type's operators are declared for the subtype. Check +-- that a call to such an operator executes the body of the type's +-- operation. +-- +-- TEST DESCRIPTION: +-- A type may declare a primitive operator, and a subtype of that type +-- may overload the operator. If a use type clause names the subtype, +-- it is the primitive operator of the type (not the subtype) which +-- is made directly visible, and the primitive operator may be called +-- unambiguously. Such a call executes the body of the type's operation. +-- +-- In a package, declare a type for which a predefined operator is +-- overridden. In another package, declare a subtype of the type in the +-- previous package. Declare another version of the predefined operator +-- for the subtype. +-- +-- The main program declares objects of both the type and the explicit +-- subtype, and uses the "**" operator for both. In all cases, the +-- operator declared for the 1st subtype should be the one executed, +-- since it is the primitive operators of the *type* that are made +-- visible; the operators which were declared for the explicit subtype +-- are not primitive operators of the type, since they were declared in +-- a separate package from the original type. +-- +-- +-- CHANGE HISTORY: +-- 06 Dec 94 SAIC ACVC 2.0 +-- 23 Sep 99 RLB Added test case where operator made visible is +-- not visible by selection (as in AI-00122). +-- +--! + +package C840001_0 is +-- Usage scenario: the predefined operators for a floating point type +-- are overridden in order to take advantage of improved algorithms. + + type Precision_Float is new Float range -100.0 .. 100.0; + -- Implicit: function "**" (Left: Precision_Float; Right: Integer'Base) + -- return Precision_Float; + + function "**" (Left: Precision_Float; Right: Integer'Base) + return Precision_Float; + -- Overrides predefined operator. + + function "+" (Right: Precision_Float) + return Precision_Float; + -- Overrides predefined operator. + + -- ... Other overridden operations. + + TC_Expected : constant Precision_Float := 68.0; + +end C840001_0; + + + --==================================================================-- + +package body C840001_0 is + + function "**" (Left: Precision_Float; Right: Integer'Base) + return Precision_Float is + begin + -- ... Utilize desired algorithm. + return (TC_Expected); -- Artificial for testing purposes. + end "**"; + + function "+" (Right: Precision_Float) + return Precision_Float is + -- Overrides predefined operator. + begin + return Right*2.0; + end "+"; + +end C840001_0; + + + --==================================================================-- + +-- Take advantage of some even better algorithms designed for positive +-- floating point values. + +with C840001_0; +package C840001_1 is + + subtype Precision_Pos_Float is C840001_0.Precision_Float + range 0.0 .. 100.0; + +-- This is not a new type, so it has no primitives of it own. However, it +-- can declare another version of the operator and call it as long as both it +-- and the corresponding operator of the 1st subtype are not directly visible +-- in the same place. + + function "**" (Left: Precision_Pos_Float; Right: Natural'Base) + return Precision_Pos_Float; -- Accepts only positive exponent. + +end C840001_1; + + + --==================================================================-- + +package body C840001_1 is + + function "**" (Left: Precision_Pos_Float; Right: Natural'Base) + return Precision_Pos_Float is + begin + -- ... Utilize some other algorithms. + return 57.0; -- Artificial for testing purposes. + end "**"; + +end C840001_1; + + + --==================================================================-- + +with Report; +with C840001_1; +procedure C840001_2 is + + -- Note that C840001_0 and it's contents is not visible in any form here. + + TC_Operand : C840001_1.Precision_Pos_Float := 41.0; + + TC_Operand2 : C840001_1.Precision_Pos_Float; + + use type C840001_1.Precision_Pos_Float; + -- Makes the operators of its parent type directly visible, even though + -- the parent type and operators are not otherwise visible at all. + +begin + + TC_Operand2 := +TC_Operand; -- Overridden operator is visible and called. + + if TC_Operand2 /= 82.0 then -- Predefined equality. + Report.Failed ("3rd test: type's overridden operation not called for " & + "operand of 1st subtype"); + end if; + if TC_Operand + 3.0 >= TC_Operand2 - 13.0 then -- Various predefined operators. + Report.Failed ("3rd test: wrong result from predefined operators"); + end if; + +end C840001_2; + + --==================================================================-- + + +with C840001_0; +with C840001_1; +with C840001_2; + +with Report; + +procedure C840001 is + +begin + Report.Test ("C840001", "Check that, for the type determined by the " & + "subtype mark of a use type clause, the declaration of " & + "each primitive operator is use-visible within the scope " & + "of the clause, even if explicit operators with the same " & + "names as the type's operators are declared for the subtype"); + + + Use_Type_Precision_Pos_Float: + declare + TC_Operand : C840001_0.Precision_Float + := C840001_0.Precision_Float(-2.0); + TC_Positive_Operand : C840001_1.Precision_Pos_Float := 6.0; + + TC_Actual_Type : C840001_0.Precision_Float; + TC_Actual_Subtype : C840001_1.Precision_Pos_Float; + + use type C840001_1.Precision_Pos_Float; + -- Both calls to "**" should return 68.0 (that is, Precision_Float's + -- operation should be called). + + begin + + TC_Actual_Type := TC_Operand**2; + + if C840001_0."/="(TC_Actual_Type, C840001_0.TC_Expected) then + Report.Failed ("1st block: type's operation not called for " & + "operand of 1st subtype"); + end if; + + TC_Actual_Subtype := TC_Positive_Operand**2; + + if not (C840001_0."=" + (TC_Actual_Subtype, C840001_0.TC_Expected)) then + Report.Failed ("1st block: type's operation not called for " & + "operand of explicit subtype"); + end if; + + end Use_Type_Precision_Pos_Float; + + Use_Type_Precision_Float: + declare + TC_Operand : C840001_0.Precision_Float + := C840001_0.Precision_Float(4.0); + TC_Positive_Operand : C840001_1.Precision_Pos_Float := 7.0; + + TC_Actual_Type : C840001_0.Precision_Float; + TC_Actual_Subtype : C840001_1.Precision_Pos_Float; + + use type C840001_0.Precision_Float; + -- Again, both calls to "**" should return 68.0. + + begin + + TC_Actual_Type := TC_Operand**2; + + if C840001_0."/="(TC_Actual_Type, C840001_0.TC_Expected) then + Report.Failed ("2nd block: type's operation not called for " & + "operand of 1st subtype"); + end if; + + TC_Actual_Subtype := TC_Positive_Operand**2; + + if not C840001_0."=" (TC_Actual_Subtype, C840001_0.TC_Expected) then + Report.Failed ("2nd block: type's operation not called for " & + "operand of explicit subtype"); + end if; + + end Use_Type_Precision_Float; + + C840001_2; -- 3rd test. + + Report.Result; + +end C840001; diff --git a/gcc/testsuite/ada/acats/tests/c8/c84002a.ada b/gcc/testsuite/ada/acats/tests/c8/c84002a.ada new file mode 100644 index 000000000..ed421e9bc --- /dev/null +++ b/gcc/testsuite/ada/acats/tests/c8/c84002a.ada @@ -0,0 +1,267 @@ +-- C84002A.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) IF A USE CLAUSE NAMES AN ENCLOSING PACKAGE, THE USE CLAUSE +-- HAS NO EFFECT. + +-- B) IF A DECLARATION IS DIRECTLY VISIBLE PRIOR TO THE OCCURRENCE +-- OF A USE CLAUSE, AND IS NOT IN THE SET OF POTENTIALLY +-- VISIBLE DECLARATIONS, IT REMAINS DIRECTLY VISIBLE AFTER THE +-- USE CLAUSE. + +-- C) IF A HOMOGRAPH FOR A POTENTIALLY VISIBLE SUBPROGRAM OR +-- OBJECT IS DECLARED AFTER A USE CLAUSE, THE POTENTIALLY +-- VISIBLE ENTITY IS NO LONGER VISIBLE. + +-- EG 02/16/84 + +WITH REPORT; + +PROCEDURE C84002A IS + + USE REPORT; + +BEGIN + + TEST("C84002A","CHECK THAT DECLARATIONS DIRECTLY VISIBLE PRIOR " & + "TO THE USE CLAUSE REMAIN VISIBLE AFTERWARDS"); + + BEGIN + + COMMENT ("CASE A : CHECK THAT IF A USE CLAUSE NAMES AN " & + "ENCLOSING PACKAGE, THE USE CLAUSE HAS NO EFFECT"); + +CASE_A : DECLARE + + PACKAGE P1 IS + X : FLOAT := 1.5; + END P1; + PACKAGE P2 IS + X : INTEGER := 15; + + USE P1; + USE P2; + + A : INTEGER := X; + END P2; + PACKAGE BODY P1 IS + BEGIN + NULL; + END P1; + PACKAGE BODY P2 IS + BEGIN + IF X /= IDENT_INT(15) OR X /= P2.X OR + A /= P2.X THEN + FAILED ("CASE A : USE CLAUSE HAS AN EFFECT"); + END IF; + END P2; + + BEGIN + + NULL; + + END CASE_A; + + COMMENT ("CASE B : CHECK THAT IF A DECLARATION IS DIRECTLY " & + "VISIBLE PRIOR TO THE OCCURRENCE OF A USE CLAUSE, " & + "AND IS NOT IN THE SET OF POTENTIALLY VISIBLE " & + "DECLARATIONS, IT REMAINS DIRECTLY VISIBLE"); + +CASE_B : BEGIN + + CASE_B1 : DECLARE + + PACKAGE P1 IS + Y : FLOAT := 1.5; + END P1; + PACKAGE P2 IS + X : INTEGER := 15; + + USE P1; + + A : INTEGER := X; + END P2; + + PACKAGE BODY P1 IS + BEGIN + NULL; + END P1; + PACKAGE BODY P2 IS + BEGIN + IF X /= IDENT_INT(15) OR X /= P2.X OR + A /= P2.X THEN + FAILED ("CASE B1 : DECLARATION NO " & + "LONGER DIRECTLY VISIBLE"); + END IF; + END P2; + + BEGIN + + NULL; + + END CASE_B1; + + CASE_B2 : DECLARE + + PROCEDURE PROC1 (X : STRING) IS + BEGIN + NULL; + END PROC1; + + PACKAGE P1 IS + PROCEDURE PROC1 (X : STRING); + END P1; + PACKAGE BODY P1 IS + PROCEDURE PROC1 (X : STRING) IS + BEGIN + FAILED ("CASE B2 : WRONG PROCEDURE " & + "DIRECTLY VISIBLE"); + END PROC1; + END P1; + + USE P1; + + BEGIN + + PROC1 ("ABC"); + + END CASE_B2; + + CASE_B3 : DECLARE + + PROCEDURE PROC1 (X : STRING) IS + BEGIN + NULL; + END PROC1; + + PACKAGE P1 IS + PROCEDURE PROC1 (Y : STRING); + END P1; + PACKAGE BODY P1 IS + PROCEDURE PROC1 (Y : STRING) IS + BEGIN + FAILED ("CASE B3 : WRONG PROCEDURE " & + "DIRECTLY VISIBLE"); + END PROC1; + END P1; + + USE P1; + + BEGIN + + PROC1 ("ABC"); + + END CASE_B3; + + END CASE_B; + + COMMENT ("CASE C : IF A HOMOGRAPH FOR A POTENTIALLY " & + "VISIBLE SUBPROGRAM OR OBJECT IS DECLARED AFTER " & + "A USE CLAUSE, THE POTENTIALLY VISIBLE ENTITY " & + "IS NO LONGER VISIBLE"); + +CASE_C : BEGIN + + CASE_C1 : DECLARE + + PACKAGE P1 IS + PROCEDURE PROC1 (X : FLOAT); + END P1; + + USE P1; + + PACKAGE BODY P1 IS + PROCEDURE PROC1 (X : FLOAT) IS + BEGIN + IF X = -1.5 THEN + FAILED ("CASE C1 : WRONG PROCEDURE" & + " CALLED (A)"); + ELSIF X /= 1.5 THEN + FAILED ("CASE C1 : WRONG VALUE " & + "PASSED (A)"); + END IF; + END PROC1; + BEGIN + NULL; + END P1; + + PROCEDURE PROC2 IS + BEGIN + PROC1 (1.5); + END PROC2; + + PROCEDURE PROC1 (X : FLOAT) IS + BEGIN + IF X = 1.5 THEN + FAILED ("CASE C1 : WRONG PROCEDURE" & + " CALLED (B)"); + ELSIF X /= -1.5 THEN + FAILED ("CASE C1 : WRONG VALUE " & + "PASSED (B)"); + END IF; + END PROC1; + + BEGIN + + PROC2; + PROC1 (-1.5); + + END CASE_C1; + + CASE_C2 : DECLARE + + PACKAGE P1 IS + X : INTEGER := 15; + END P1; + + USE P1; + + A : INTEGER := X; + + X : BOOLEAN := TRUE; + + B : BOOLEAN := X; + + BEGIN + + IF A /= IDENT_INT(15) THEN + FAILED ("CASE C2 : VARIABLE A DOES NOT " & + "CONTAIN THE CORRECT VALUE"); + END IF; + IF B /= IDENT_BOOL(TRUE) THEN + FAILED ("CASE C2 : VARIABLE B DOES NOT " & + "CONTAIN THE CORRECT VALUE"); + END IF; + + END CASE_C2; + + END CASE_C; + + END; + + RESULT; + +END C84002A; diff --git a/gcc/testsuite/ada/acats/tests/c8/c84005a.ada b/gcc/testsuite/ada/acats/tests/c8/c84005a.ada new file mode 100644 index 000000000..53bd64a3d --- /dev/null +++ b/gcc/testsuite/ada/acats/tests/c8/c84005a.ada @@ -0,0 +1,117 @@ +-- C84005A.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 TWO POTENTIALLY VISIBLE HOMOGRAPHS OF A SUBPROGRAM +-- IDENTIFIER CAN BE MADE DIRECTLY VISIBLE BY A USE CLAUSE, AND THAT +-- WHEN DIFFERENT FORMAL PARAMETER NAMES ARE USED THE SUBPROGRAMS +-- ARE REFERENCED CORRECTLY. + +-- HISTORY: +-- JET 03/10/88 CREATED ORIGINAL TEST. + +WITH REPORT; USE REPORT; +PROCEDURE C84005A IS + + PACKAGE PACK1 IS + FUNCTION FUNK(A : INTEGER) RETURN INTEGER; + PROCEDURE PROK(A : INTEGER; B : OUT INTEGER); + END PACK1; + + PACKAGE PACK2 IS + FUNCTION FUNK(X : INTEGER) RETURN INTEGER; + PROCEDURE PROK(X : INTEGER; Y : OUT INTEGER); + END PACK2; + + USE PACK1, PACK2; + VAR1, VAR2 : INTEGER; + + PACKAGE BODY PACK1 IS + FUNCTION FUNK(A : INTEGER) RETURN INTEGER IS + BEGIN + IF EQUAL (A,A) THEN + RETURN (1); + ELSE + RETURN (0); + END IF; + END FUNK; + + PROCEDURE PROK(A : INTEGER; B : OUT INTEGER) IS + BEGIN + IF EQUAL (A,A) THEN + B := 1; + ELSE + B := 0; + END IF; + END PROK; + END PACK1; + + PACKAGE BODY PACK2 IS + FUNCTION FUNK(X : INTEGER) RETURN INTEGER IS + BEGIN + IF EQUAL (X,X) THEN + RETURN (2); + ELSE + RETURN (0); + END IF; + END FUNK; + + PROCEDURE PROK(X : INTEGER; Y : OUT INTEGER) IS + BEGIN + IF EQUAL (X,X) THEN + Y := 2; + ELSE + Y := 0; + END IF; + END PROK; + END PACK2; + +BEGIN + TEST ("C84005A", "CHECK THAT TWO POTENTIALLY VISIBLE HOMOGRAPHS " & + "OF A SUBPROGRAM IDENTIFIER CAN BE MADE " & + "DIRECTLY VISIBLE BY A USE CLAUSE, AND THAT " & + "WHEN DIFFERENT FORMAL PARAMETER NAMES ARE " & + "USED, THE SUBPROGRAMS ARE REFERENCED CORRECTLY"); + + IF FUNK(A => 3) /= IDENT_INT(1) THEN + FAILED("PACK1.FUNK RETURNS INCORRECT RESULT"); + END IF; + + IF FUNK(X => 3) /= IDENT_INT(2) THEN + FAILED("PACK2.FUNK RETURNS INCORRECT RESULT"); + END IF; + + PROK(A => 3, B => VAR1); + PROK(X => 3, Y => VAR2); + + IF VAR1 /= IDENT_INT(1) THEN + FAILED("PACK1.PROK RETURNS INCORRECT RESULT"); + END IF; + + IF VAR2 /= IDENT_INT(2) THEN + FAILED("PACK2.PROK RETURNS INCORRECT RESULT"); + END IF; + + RESULT; +END C84005A; diff --git a/gcc/testsuite/ada/acats/tests/c8/c84008a.ada b/gcc/testsuite/ada/acats/tests/c8/c84008a.ada new file mode 100644 index 000000000..fb760eddc --- /dev/null +++ b/gcc/testsuite/ada/acats/tests/c8/c84008a.ada @@ -0,0 +1,83 @@ +-- C84008A.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 THE NAMES MADE VISIBLE BY A USE CLAUSE IN THE VISIBLE +-- PART OF A PACKAGE ARE VISIBLE IN THE PRIVATE PART AND BODY OF +-- THE PACKAGE. + +-- HISTORY: +-- JET 03/10/88 CREATED ORIGINAL TEST. + +WITH REPORT; USE REPORT; +PROCEDURE C84008A IS + + PACKAGE PACK1 IS + TYPE A IS RANGE 0..100; + TYPE B IS RANGE -100..0; + END PACK1; + + PACKAGE PACK2 IS + USE PACK1; + TYPE C IS PRIVATE; + PROCEDURE PROC (X : OUT A; Y : OUT B); + PRIVATE + TYPE C IS NEW A RANGE 0..9; + END PACK2; + + VAR1 : PACK1.A; + VAR2 : PACK1.B; + + PACKAGE BODY PACK2 IS + PROCEDURE PROC (X : OUT A; Y : OUT B) IS + SUBTYPE D IS B RANGE -9..0; + BEGIN + IF EQUAL(3,3) THEN + X := A'(2); + Y := D'(-2); + ELSE + X := A'(0); + Y := D'(0); + END IF; + END PROC; + END PACK2; + +BEGIN + TEST ("C84008A", "CHECK THAT THE NAMES MADE VISIBLE BY A USE " & + "CLAUSE IN THE VISIBLE PART OF A PACKAGE ARE " & + "VISIBLE IN THE PRIVATE PART AND BODY OF " & + "THE PACKAGE"); + + PACK2.PROC (VAR1,VAR2); + + IF PACK1."/=" (VAR1, 2) THEN + FAILED("INCORRECT RETURN VALUE FOR VAR1"); + END IF; + + IF PACK1."/=" (VAR2, PACK1."-"(2)) THEN + FAILED("INCORRECT RETURN VALUE FOR VAR2"); + END IF; + + RESULT; +END C84008A; diff --git a/gcc/testsuite/ada/acats/tests/c8/c84009a.ada b/gcc/testsuite/ada/acats/tests/c8/c84009a.ada new file mode 100644 index 000000000..afc5fe0da --- /dev/null +++ b/gcc/testsuite/ada/acats/tests/c8/c84009a.ada @@ -0,0 +1,99 @@ +-- C84009A.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 A USE CLAUSE MAKES AN IMPLICITLY OR EXPLICITLY +-- DECLARED OPERATOR DIRECTLY VISIBLE IF NO HOMOGRAPH OF THE +-- OPERATOR IS ALREADY DIRECTLY VISIBLE. + +-- HISTORY: +-- JET 03/10/88 CREATED ORIGINAL TEST. + +WITH REPORT; USE REPORT; +PROCEDURE C84009A IS + + TYPE INT IS NEW INTEGER RANGE -100 .. 100; + + PACKAGE PACK IS + FUNCTION "+" (LEFT : INTEGER; RIGHT : INT) RETURN INTEGER; + FUNCTION "-" (LEFT, RIGHT : INT) RETURN INT; + FUNCTION "-" (RIGHT : INT) RETURN INTEGER; + FUNCTION "+" (RIGHT : INT) RETURN INTEGER; + END PACK; + + FUNCTION "+" (RIGHT : INT) RETURN INTEGER IS + BEGIN + RETURN INTEGER'(1) + INTEGER(RIGHT); + END "+"; + + PACKAGE BODY PACK IS + FUNCTION "+" (LEFT : INTEGER; RIGHT : INT) RETURN INTEGER IS + BEGIN + RETURN LEFT + INTEGER(RIGHT); + END "+"; + + FUNCTION "-" (LEFT, RIGHT : INT) RETURN INT IS + BEGIN + FAILED ("BINARY ""-"" ALREADY VISIBLE FOR TYPE INT"); + RETURN LEFT + (-RIGHT); + END "-"; + + FUNCTION "-" (RIGHT : INT) RETURN INTEGER IS + BEGIN + RETURN INTEGER'(0) - INTEGER(RIGHT); + END "-"; + + FUNCTION "+" (RIGHT : INT) RETURN INTEGER IS + BEGIN + FAILED ("UNARY ""+"" ALREADY VISIBLE FOR TYPE INT"); + RETURN INTEGER'(0) + INTEGER(RIGHT); + END "+"; + END PACK; + + USE PACK; + +BEGIN + TEST ("C84009A", "CHECK THAT A USE CLAUSE MAKES AN IMPLICITLY " & + "OR EXPLICITLY DECLARED OPERATOR DIRECTLY " & + "VISIBLE IF NO HOMOGRAPH OF THE OPERATOR IS " & + "ALREADY DIRECTLY VISIBLE"); + + IF INTEGER'(10) + INT'(10) /= IDENT_INT(20) THEN + FAILED ("INCORRECT RESULT FROM BINARY ""+"""); + END IF; + + IF INT'(5) - INT'(3) /= INT'(2) THEN + FAILED ("INCORRECT RESULT FROM BINARY ""-"""); + END IF; + + IF -INT'(20) /= IDENT_INT(-INTEGER'(20)) THEN + FAILED ("INCORRECT RESULT FROM UNARY ""-"""); + END IF; + + IF +INT'(20) /= IDENT_INT(+INTEGER'(21)) THEN + FAILED ("INCORRECT RESULT FROM UNARY ""+"""); + END IF; + + RESULT; +END C84009A; diff --git a/gcc/testsuite/ada/acats/tests/c8/c85004b.ada b/gcc/testsuite/ada/acats/tests/c8/c85004b.ada new file mode 100644 index 000000000..515936fe9 --- /dev/null +++ b/gcc/testsuite/ada/acats/tests/c8/c85004b.ada @@ -0,0 +1,164 @@ +-- C85004B.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 A RENAMED CONSTANT OBJECT, "IN" PARAMETER OF A +-- SUBPROGRAM OR ENTRY, "IN" FORMAL GENERIC, RECORD DISCRIMINANT, +-- LOOP PARAMETER, DEFERRED CONSTANT, OR RENAMED CONSTANT HAS THE +-- CORRECT VALUE. + +-- HISTORY: +-- JET 07/25/88 CREATED ORIGINAL TEST. + +WITH REPORT; USE REPORT; +PROCEDURE C85004B IS + + TYPE A IS ARRAY (POSITIVE RANGE <>) OF INTEGER; + SUBTYPE P IS POSITIVE RANGE 1 .. 10; + + C1 : CONSTANT INTEGER := 1; + X1 : INTEGER RENAMES C1; + X2 : INTEGER RENAMES X1; + + TYPE REC (D : P := 1) IS + RECORD + I : A(1..D); + END RECORD; + TYPE ACCREC1 IS ACCESS REC; + TYPE ACCREC2 IS ACCESS REC(10); + + R1 : REC; + R2 : REC(10); + AR1 : ACCREC1 := NEW REC; + AR2 : ACCREC2 := NEW REC(10); + + X3 : P RENAMES R1.D; + X4 : P RENAMES R2.D; + X5 : P RENAMES AR1.D; + X6 : P RENAMES AR2.D; + + C2 : CONSTANT A(1..3) := (1, 2, 3); + X7 : INTEGER RENAMES C2(1); + + GENERIC + K1 : IN INTEGER; + PACKAGE GENPKG IS + TYPE K IS PRIVATE; + K2 : CONSTANT K; + PRIVATE + TYPE K IS RANGE 1..100; + K2 : CONSTANT K := 5; + END GENPKG; + + TASK FOOEY IS + ENTRY ENT1 (I : IN INTEGER); + END FOOEY; + + TASK BODY FOOEY IS + BEGIN + ACCEPT ENT1 (I : IN INTEGER) DO + DECLARE + TX1 : INTEGER RENAMES I; + BEGIN + IF TX1 /= IDENT_INT(2) THEN + FAILED ("INCORRECT VALUE"); + END IF; + END; + END ENT1; + END FOOEY; + + PACKAGE BODY GENPKG IS + KX1 : INTEGER RENAMES K1; + KX2 : K RENAMES K2; + BEGIN + IF KX1 /= IDENT_INT(4) THEN + FAILED ("INCORRECT VALUE OF KX1"); + END IF; + + IF KX2 /= K(IDENT_INT(5)) THEN + FAILED ("INCORRECT VALUE OF KX2"); + END IF; + END GENPKG; + + PROCEDURE PROC (I : IN INTEGER) IS + PX1 : INTEGER RENAMES I; + BEGIN + IF PX1 /= IDENT_INT(3) THEN + FAILED ("INCORRECT VALUE OF PX1"); + END IF; + END PROC; + + PACKAGE PKG IS NEW GENPKG(4); + +BEGIN + TEST ("C85004B", "CHECK THAT A RENAMED CONSTANT OBJECT, 'IN' " & + "PARAMETER OF A SUBPROGRAM OR ENTRY, 'IN' FORMAL GENERIC, " & + "RECORD DISCRIMINANT, LOOP PARAMETER, DEFERRED CONSTANT, " & + "OR RENAMED CONSTANT HAS THE CORRECT VALUE"); + + FOOEY.ENT1(2); + + PROC(3); + + IF X1 /= IDENT_INT(1) THEN + FAILED ("INCORRECT VALUE OF X1"); + END IF; + + IF X2 /= IDENT_INT(1) THEN + FAILED ("INCORRECT VALUE OF X2"); + END IF; + + IF X3 /= IDENT_INT(1) THEN + FAILED ("INCORRECT VALUE OF X3"); + END IF; + + IF X4 /= IDENT_INT(10) THEN + FAILED ("INCORRECT VALUE OF X4"); + END IF; + + IF X5 /= IDENT_INT(1) THEN + FAILED ("INCORRECT VALUE OF X5"); + END IF; + + IF X6 /= IDENT_INT(10) THEN + FAILED ("INCORRECT VALUE OF X6"); + END IF; + + IF X7 /= IDENT_INT(1) THEN + FAILED ("INCORRECT VALUE OF X7"); + END IF; + + FOR I IN 1..IDENT_INT(2) LOOP + DECLARE + X8 : INTEGER RENAMES I; + BEGIN + IF X8 /= IDENT_INT(I) THEN + FAILED ("INCORRECT VALUE OF X8"); + END IF; + END; + END LOOP; + + RESULT; + +END C85004B; diff --git a/gcc/testsuite/ada/acats/tests/c8/c85005a.ada b/gcc/testsuite/ada/acats/tests/c8/c85005a.ada new file mode 100644 index 000000000..05dc328bd --- /dev/null +++ b/gcc/testsuite/ada/acats/tests/c8/c85005a.ada @@ -0,0 +1,391 @@ +-- C85005A.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 A VARIABLE CREATED BY AN OBJECT DECLARATION CAN BE +-- RENAMED AND HAS THE CORRECT VALUE, AND THAT THE NEW NAME CAN +-- BE USED IN AN ASSIGNMENT STATEMENT AND PASSED ON AS AN ACTUAL +-- SUBPROGRAM OR ENTRY 'IN OUT' OR 'OUT' PARAMETER, AND AS AN +-- ACTUAL GENERIC 'IN OUT' PARAMETER, AND THAT WHEN THE VALUE OF +-- THE RENAMED VARIABLE IS CHANGED, THE NEW VALUE IS REFLECTED +-- BY THE VALUE OF THE NEW NAME. + +-- HISTORY: +-- JET 03/15/88 CREATED ORIGINAL TEST. + +WITH REPORT; USE REPORT; +PROCEDURE C85005A IS + + TYPE ARRAY1 IS ARRAY (POSITIVE RANGE <>) OF INTEGER; + TYPE RECORD1 (D : INTEGER) IS + RECORD + FIELD1 : INTEGER := 1; + END RECORD; + TYPE POINTER1 IS ACCESS INTEGER; + + PACKAGE PACK1 IS + K1 : INTEGER := 0; + TYPE PRIVY IS PRIVATE; + ZERO : CONSTANT PRIVY; + ONE : CONSTANT PRIVY; + TWO : CONSTANT PRIVY; + THREE : CONSTANT PRIVY; + FOUR : CONSTANT PRIVY; + FIVE : CONSTANT PRIVY; + FUNCTION IDENT (I : PRIVY) RETURN PRIVY; + FUNCTION NEXT (I : PRIVY) RETURN PRIVY; + PRIVATE + TYPE PRIVY IS RANGE 0..127; + ZERO : CONSTANT PRIVY := 0; + ONE : CONSTANT PRIVY := 1; + TWO : CONSTANT PRIVY := 2; + THREE : CONSTANT PRIVY := 3; + FOUR : CONSTANT PRIVY := 4; + FIVE : CONSTANT PRIVY := 5; + END PACK1; + + TASK TYPE TASK1 IS + ENTRY ASSIGN (J : IN INTEGER); + ENTRY VALU (J : OUT INTEGER); + ENTRY NEXT; + ENTRY STOP; + END TASK1; + + TASK TYPE TASK2 IS + ENTRY ENTRY1 (TI1 : OUT INTEGER; TA1 : OUT ARRAY1; + TR1 : OUT RECORD1; TP1 : IN OUT POINTER1; + TV1 : IN OUT PACK1.PRIVY; TT1 : IN OUT TASK1; + TK1 : IN OUT INTEGER); + END TASK2; + + I1 : INTEGER := 0; + A1 : ARRAY1(1..3) := (OTHERS => 0); + R1 : RECORD1(1) := (D => 1, FIELD1 => 0); + P1 : POINTER1 := NEW INTEGER'(0); + V1 : PACK1.PRIVY := PACK1.ZERO; + T1 : TASK1; + + XI1 : INTEGER RENAMES I1; + XA1 : ARRAY1 RENAMES A1; + XR1 : RECORD1 RENAMES R1; + XP1 : POINTER1 RENAMES P1; + XV1 : PACK1.PRIVY RENAMES V1; + XT1 : TASK1 RENAMES T1; + XK1 : INTEGER RENAMES PACK1.K1; + + I : INTEGER; + CHK_TASK : TASK2; + + GENERIC + GI1 : IN OUT INTEGER; + GA1 : IN OUT ARRAY1; + GR1 : IN OUT RECORD1; + GP1 : IN OUT POINTER1; + GV1 : IN OUT PACK1.PRIVY; + GT1 : IN OUT TASK1; + GK1 : IN OUT INTEGER; + PACKAGE GENERIC1 IS + END GENERIC1; + + FUNCTION IDENT (P : POINTER1) RETURN POINTER1 IS + BEGIN + IF EQUAL (3,3) THEN + RETURN P; + ELSE + RETURN NULL; + END IF; + END IDENT; + + PROCEDURE PROC1 (PI1 : IN OUT INTEGER; PA1 : IN OUT ARRAY1; + PR1 : IN OUT RECORD1; PP1 : OUT POINTER1; + PV1 : OUT PACK1.PRIVY; PT1 : IN OUT TASK1; + PK1 : OUT INTEGER) IS + + BEGIN + PI1 := PI1 + 1; + PA1 := (PA1(1)+1, PA1(2)+1, PA1(3)+1); + PR1 := (D => 1, FIELD1 => PR1.FIELD1 + 1); + PP1 := NEW INTEGER'(P1.ALL + 1); + PV1 := PACK1.NEXT(V1); + PT1.NEXT; + PK1 := PACK1.K1 + 1; + END PROC1; + + PACKAGE BODY PACK1 IS + FUNCTION IDENT (I : PRIVY) RETURN PRIVY IS + BEGIN + IF EQUAL(3,3) THEN + RETURN I; + ELSE + RETURN PRIVY'(0); + END IF; + END IDENT; + + FUNCTION NEXT (I : PRIVY) RETURN PRIVY IS + BEGIN + RETURN I+1; + END NEXT; + END PACK1; + + PACKAGE BODY GENERIC1 IS + BEGIN + GI1 := GI1 + 1; + GA1 := (GA1(1)+1, GA1(2)+1, GA1(3)+1); + GR1 := (D => 1, FIELD1 => GR1.FIELD1+1); + GP1 := NEW INTEGER'(GP1.ALL + 1); + GV1 := PACK1.NEXT(GV1); + GT1.NEXT; + GK1 := GK1 + 1; + END GENERIC1; + + TASK BODY TASK1 IS + TASK_VALUE : INTEGER := 0; + ACCEPTING_ENTRIES : BOOLEAN := TRUE; + BEGIN + WHILE ACCEPTING_ENTRIES LOOP + SELECT + ACCEPT ASSIGN (J : IN INTEGER) DO + TASK_VALUE := J; + END ASSIGN; + OR + ACCEPT VALU (J : OUT INTEGER) DO + J := TASK_VALUE; + END VALU; + OR + ACCEPT NEXT DO + TASK_VALUE := TASK_VALUE + 1; + END NEXT; + OR + ACCEPT STOP DO + ACCEPTING_ENTRIES := FALSE; + END STOP; + END SELECT; + END LOOP; + END TASK1; + + TASK BODY TASK2 IS + BEGIN + ACCEPT ENTRY1 (TI1 : OUT INTEGER; TA1 : OUT ARRAY1; + TR1 : OUT RECORD1; TP1 : IN OUT POINTER1; + TV1 : IN OUT PACK1.PRIVY; TT1 : IN OUT TASK1; + TK1 : IN OUT INTEGER) DO + + TI1 := I1 + 1; + TA1 := (A1(1)+1, A1(2)+1, A1(3)+1); + TR1 := (D => 1, FIELD1 => R1.FIELD1 + 1); + TP1 := NEW INTEGER'(TP1.ALL + 1); + TV1 := PACK1.NEXT(TV1); + TT1.NEXT; + TK1 := TK1 + 1; + END ENTRY1; + END TASK2; + +BEGIN + TEST ("C85005A", "CHECK THAT A VARIABLE CREATED BY AN OBJECT " & + "DECLARATION CAN BE RENAMED AND HAS THE " & + "CORRECT VALUE, AND THAT THE NEW NAME CAN " & + "BE USED IN AN ASSIGNMENT STATEMENT " & + "AND PASSED ON AS AN ACTUAL SUBPROGRAM OR " & + "ENTRY 'IN OUT' OR 'OUT' PARAMETER, AND AS AN " & + "ACTUAL GENERIC 'IN OUT' PARAMETER, AND THAT " & + "WHEN THE VALUE OF THE RENAMED VARIABLE IS " & + "CHANGED, THE NEW VALUE IS REFLECTED BY THE " & + "VALUE OF THE NEW NAME"); + + DECLARE + PACKAGE GENPACK1 IS NEW + GENERIC1 (XI1, XA1, XR1, XP1, XV1, XT1, XK1); + BEGIN + NULL; + END; + + IF XI1 /= IDENT_INT(1) THEN + FAILED ("INCORRECT VALUE OF XI1 (1)"); + END IF; + + IF XA1 /= (IDENT_INT(1),IDENT_INT(1),IDENT_INT(1)) THEN + FAILED ("INCORRECT VALUE OF XA1 (1)"); + END IF; + + IF XR1 /= (D => 1, FIELD1 => IDENT_INT(1)) THEN + FAILED ("INCORRECT VALUE OF XR1 (1)"); + END IF; + + IF XP1 /= IDENT(P1) OR XP1.ALL /= IDENT_INT(1) THEN + FAILED ("INCORRECT VALUE OF XP1 (1)"); + END IF; + + IF PACK1."/=" (XV1, PACK1.IDENT(PACK1.ONE)) THEN + FAILED ("INCORRECT VALUE OF XV1 (1)"); + END IF; + + XT1.VALU(I); + IF I /= IDENT_INT(1) THEN + FAILED ("INCORRECT RETURN VALUE OF XT1.VALU (1)"); + END IF; + + IF XK1 /= IDENT_INT(1) THEN + FAILED ("INCORRECT VALUE OF XK1 (1)"); + END IF; + + PROC1(XI1, XA1, XR1, XP1, XV1, XT1, XK1); + + IF XI1 /= IDENT_INT(2) THEN + FAILED ("INCORRECT VALUE OF XI1 (2)"); + END IF; + + IF XA1 /= (IDENT_INT(2),IDENT_INT(2),IDENT_INT(2)) THEN + FAILED ("INCORRECT VALUE OF XA1 (2)"); + END IF; + + IF XR1 /= (D => 1, FIELD1 => IDENT_INT(2)) THEN + FAILED ("INCORRECT VALUE OF XR1 (2)"); + END IF; + + IF XP1 /= IDENT(P1) OR XP1.ALL /= IDENT_INT(2) THEN + FAILED ("INCORRECT VALUE OF XP1 (2)"); + END IF; + + IF PACK1."/=" (XV1, PACK1.IDENT(PACK1.TWO)) THEN + FAILED ("INCORRECT VALUE OF XV1 (2)"); + END IF; + + XT1.VALU(I); + IF I /= IDENT_INT(2) THEN + FAILED ("INCORRECT RETURN VALUE FROM XT1.VALU (2)"); + END IF; + + IF XK1 /= IDENT_INT(2) THEN + FAILED ("INCORRECT VALUE OF XK1 (2)"); + END IF; + + CHK_TASK.ENTRY1(XI1, XA1, XR1, XP1, XV1, XT1, XK1); + + IF XI1 /= IDENT_INT(3) THEN + FAILED ("INCORRECT VALUE OF XI1 (3)"); + END IF; + + IF XA1 /= (IDENT_INT(3),IDENT_INT(3),IDENT_INT(3)) THEN + FAILED ("INCORRECT VALUE OF XA1 (3)"); + END IF; + + IF XR1 /= (D => 1, FIELD1 => IDENT_INT(3)) THEN + FAILED ("INCORRECT VALUE OF XR1 (3)"); + END IF; + + IF XP1 /= IDENT(P1) OR XP1.ALL /= IDENT_INT(3) THEN + FAILED ("INCORRECT VALUE OF XP1 (3)"); + END IF; + + IF PACK1."/=" (XV1, PACK1.IDENT(PACK1.THREE)) THEN + FAILED ("INCORRECT VALUE OF XV1 (3)"); + END IF; + + XT1.VALU(I); + IF I /= IDENT_INT(3) THEN + FAILED ("INCORRECT RETURN VALUE OF XT1.VALU (3)"); + END IF; + + IF XK1 /= IDENT_INT(3) THEN + FAILED ("INCORRECT VALUE OF XK1 (3)"); + END IF; + + XI1 := XI1 + 1; + XA1 := (XA1(1)+1, XA1(2)+1, XA1(3)+1); + XR1 := (D => 1, FIELD1 => XR1.FIELD1 + 1); + XP1 := NEW INTEGER'(XP1.ALL + 1); + XV1 := PACK1.NEXT(XV1); + XT1.NEXT; + XK1 := XK1 + 1; + + IF XI1 /= IDENT_INT(4) THEN + FAILED ("INCORRECT VALUE OF XI1 (4)"); + END IF; + + IF XA1 /= (IDENT_INT(4),IDENT_INT(4),IDENT_INT(4)) THEN + FAILED ("INCORRECT VALUE OF XA1 (4)"); + END IF; + + IF XR1 /= (D => 1, FIELD1 => IDENT_INT(4)) THEN + FAILED ("INCORRECT VALUE OF XR1 (4)"); + END IF; + + IF XP1 /= IDENT(P1) OR XP1.ALL /= IDENT_INT(4) THEN + FAILED ("INCORRECT VALUE OF XP1 (4)"); + END IF; + + IF PACK1."/=" (XV1, PACK1.IDENT(PACK1.FOUR)) THEN + FAILED ("INCORRECT VALUE OF XV1 (4)"); + END IF; + + XT1.VALU(I); + IF I /= IDENT_INT(4) THEN + FAILED ("INCORRECT RETURN VALUE OF XT1.VALU (4)"); + END IF; + + IF XK1 /= IDENT_INT(4) THEN + FAILED ("INCORRECT VALUE OF XK1 (4)"); + END IF; + + I1 := I1 + 1; + A1 := (A1(1)+1, A1(2)+1, A1(3)+1); + R1 := (D => 1, FIELD1 => R1.FIELD1 + 1); + P1 := NEW INTEGER'(P1.ALL + 1); + V1 := PACK1.NEXT(V1); + T1.NEXT; + PACK1.K1 := PACK1.K1 + 1; + + IF XI1 /= IDENT_INT(5) THEN + FAILED ("INCORRECT VALUE OF XI1 (5)"); + END IF; + + IF XA1 /= (IDENT_INT(5),IDENT_INT(5),IDENT_INT(5)) THEN + FAILED ("INCORRECT VALUE OF XA1 (5)"); + END IF; + + IF XR1 /= (D => 1, FIELD1 => IDENT_INT(5)) THEN + FAILED ("INCORRECT VALUE OF XR1 (5)"); + END IF; + + IF XP1 /= IDENT(P1) OR XP1.ALL /= IDENT_INT(5) THEN + FAILED ("INCORRECT VALUE OF XP1 (5)"); + END IF; + + IF PACK1."/=" (XV1, PACK1.IDENT(PACK1.FIVE)) THEN + FAILED ("INCORRECT VALUE OF XV1 (5)"); + END IF; + + XT1.VALU(I); + IF I /= IDENT_INT(5) THEN + FAILED ("INCORRECT RETURN VALUE OF XT1.VALU (5)"); + END IF; + + IF XK1 /= IDENT_INT(5) THEN + FAILED ("INCORRECT VALUE OF XK1 (5)"); + END IF; + + T1.STOP; + + RESULT; +END C85005A; diff --git a/gcc/testsuite/ada/acats/tests/c8/c85005b.ada b/gcc/testsuite/ada/acats/tests/c8/c85005b.ada new file mode 100644 index 000000000..9c4f6fe96 --- /dev/null +++ b/gcc/testsuite/ada/acats/tests/c8/c85005b.ada @@ -0,0 +1,366 @@ +-- C85005B.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 A VARIABLE CREATED BY A SUBPROGRAM 'IN OUT' FORMAL +-- PARAMETER CAN BE RENAMED AND HAS THE CORRECT VALUE, AND THAT +-- THE NEW NAME CAN BE USED IN AN ASSIGNMENT STATEMENT AND PASSED +-- ON AS AN ACTUAL SUBPROGRAM OR ENTRY 'IN OUT' OR 'OUT' PARAMETER, +-- AND AS AN ACTUAL GENERIC 'IN OUT' PARAMETER, AND THAT WHEN THE +-- VALUE OF THE RENAMED VARIABLE IS CHANGED, THE NEW VALUE IS +-- REFLECTED BY THE VALUE OF THE NEW NAME. + +-- HISTORY: +-- JET 03/15/88 CREATED ORIGINAL TEST. + +WITH REPORT; USE REPORT; +PROCEDURE C85005B IS + + TYPE ARRAY1 IS ARRAY (POSITIVE RANGE <>) OF INTEGER; + TYPE RECORD1 (D : INTEGER) IS + RECORD + FIELD1 : INTEGER := 1; + END RECORD; + TYPE POINTER1 IS ACCESS INTEGER; + + PACKAGE PACK1 IS + TYPE PRIVY IS PRIVATE; + ZERO : CONSTANT PRIVY; + ONE : CONSTANT PRIVY; + TWO : CONSTANT PRIVY; + THREE : CONSTANT PRIVY; + FOUR : CONSTANT PRIVY; + FIVE : CONSTANT PRIVY; + FUNCTION IDENT (I : PRIVY) RETURN PRIVY; + FUNCTION NEXT (I : PRIVY) RETURN PRIVY; + PRIVATE + TYPE PRIVY IS RANGE 0..127; + ZERO : CONSTANT PRIVY := 0; + ONE : CONSTANT PRIVY := 1; + TWO : CONSTANT PRIVY := 2; + THREE : CONSTANT PRIVY := 3; + FOUR : CONSTANT PRIVY := 4; + FIVE : CONSTANT PRIVY := 5; + END PACK1; + + TASK TYPE TASK1 IS + ENTRY ASSIGN (J : IN INTEGER); + ENTRY VALU (J : OUT INTEGER); + ENTRY NEXT; + ENTRY STOP; + END TASK1; + + DI1 : INTEGER := 0; + DA1 : ARRAY1(1..3) := (OTHERS => 0); + DR1 : RECORD1(1) := (D => 1, FIELD1 => 0); + DP1 : POINTER1 := NEW INTEGER'(0); + DV1 : PACK1.PRIVY := PACK1.ZERO; + DT1 : TASK1; + + I : INTEGER; + + GENERIC + GI1 : IN OUT INTEGER; + GA1 : IN OUT ARRAY1; + GR1 : IN OUT RECORD1; + GP1 : IN OUT POINTER1; + GV1 : IN OUT PACK1.PRIVY; + GT1 : IN OUT TASK1; + PACKAGE GENERIC1 IS + END GENERIC1; + + FUNCTION IDENT (P : POINTER1) RETURN POINTER1 IS + BEGIN + IF EQUAL (3,3) THEN + RETURN P; + ELSE + RETURN NULL; + END IF; + END IDENT; + + PACKAGE BODY PACK1 IS + FUNCTION IDENT (I : PRIVY) RETURN PRIVY IS + BEGIN + IF EQUAL(3,3) THEN + RETURN I; + ELSE + RETURN PRIVY'(0); + END IF; + END IDENT; + + FUNCTION NEXT (I : PRIVY) RETURN PRIVY IS + BEGIN + RETURN I+1; + END NEXT; + END PACK1; + + PACKAGE BODY GENERIC1 IS + BEGIN + GI1 := GI1 + 1; + GA1 := (GA1(1)+1, GA1(2)+1, GA1(3)+1); + GR1 := (D => 1, FIELD1 => GR1.FIELD1 + 1); + GP1 := NEW INTEGER'(GP1.ALL + 1); + GV1 := PACK1.NEXT(GV1); + GT1.NEXT; + END GENERIC1; + + TASK BODY TASK1 IS + TASK_VALUE : INTEGER := 0; + ACCEPTING_ENTRIES : BOOLEAN := TRUE; + BEGIN + WHILE ACCEPTING_ENTRIES LOOP + SELECT + ACCEPT ASSIGN (J : IN INTEGER) DO + TASK_VALUE := J; + END ASSIGN; + OR + ACCEPT VALU (J : OUT INTEGER) DO + J := TASK_VALUE; + END VALU; + OR + ACCEPT NEXT DO + TASK_VALUE := TASK_VALUE + 1; + END NEXT; + OR + ACCEPT STOP DO + ACCEPTING_ENTRIES := FALSE; + END STOP; + END SELECT; + END LOOP; + END TASK1; + + PROCEDURE PROC (PI1 : IN OUT INTEGER; PA1 : IN OUT ARRAY1; + PR1 : IN OUT RECORD1; PP1 : IN OUT POINTER1; + PV1 : IN OUT PACK1.PRIVY; PT1 : IN OUT TASK1) IS + XPI1 : INTEGER RENAMES PI1; + XPA1 : ARRAY1 RENAMES PA1; + XPR1 : RECORD1 RENAMES PR1; + XPP1 : POINTER1 RENAMES PP1; + XPV1 : PACK1.PRIVY RENAMES PV1; + XPT1 : TASK1 RENAMES PT1; + + TASK TYPE TASK2 IS + ENTRY ENTRY1 (TI1 : OUT INTEGER; TA1 : OUT ARRAY1; + TR1 : OUT RECORD1; TP1 : IN OUT POINTER1; + TV1 : IN OUT PACK1.PRIVY; + TT1 : IN OUT TASK1); + END TASK2; + + CHK_TASK : TASK2; + + PROCEDURE PROC1 (PPI1 : IN OUT INTEGER; PPA1 : IN OUT ARRAY1; + PPR1 : IN OUT RECORD1; PPP1 : OUT POINTER1; + PPV1 : OUT PACK1.PRIVY; + PPT1 : IN OUT TASK1) IS + BEGIN + PPI1 := PPI1 + 1; + PPA1 := (PPA1(1)+1, PPA1(2)+1, PPA1(3)+1); + PPR1 := (D => 1, FIELD1 => PPR1.FIELD1 + 1); + PPP1 := NEW INTEGER'(PP1.ALL + 1); + PPV1 := PACK1.NEXT(PV1); + PPT1.NEXT; + END PROC1; + + TASK BODY TASK2 IS + BEGIN + ACCEPT ENTRY1 (TI1 : OUT INTEGER; TA1 : OUT ARRAY1; + TR1 : OUT RECORD1; TP1 : IN OUT POINTER1; + TV1 : IN OUT PACK1.PRIVY; + TT1 : IN OUT TASK1) + DO + TI1 := PI1 + 1; + TA1 := (PA1(1)+1, PA1(2)+1, PA1(3)+1); + TR1 := (D => 1, FIELD1 => PR1.FIELD1 + 1); + TP1 := NEW INTEGER'(TP1.ALL + 1); + TV1 := PACK1.NEXT(TV1); + TT1.NEXT; + END ENTRY1; + END TASK2; + + PACKAGE GENPACK1 IS NEW GENERIC1 + (XPI1, XPA1, XPR1, XPP1, XPV1, XPT1); + + BEGIN + IF XPI1 /= IDENT_INT(1) THEN + FAILED ("INCORRECT VALUE OF XPI1 (1)"); + END IF; + + IF XPA1 /= (IDENT_INT(1),IDENT_INT(1),IDENT_INT(1)) THEN + FAILED ("INCORRECT VALUE OF XPA1 (1)"); + END IF; + + IF XPR1 /= (D => 1, FIELD1 => IDENT_INT(1)) THEN + FAILED ("INCORRECT VALUE OF XPR1 (1)"); + END IF; + + IF XPP1 /= IDENT(PP1) OR XPP1.ALL /= IDENT_INT(1) THEN + FAILED ("INCORRECT VALUE OF XPP1 (1)"); + END IF; + + IF PACK1."/=" (XPV1, PACK1.IDENT(PACK1.ONE)) THEN + FAILED ("INCORRECT VALUE OF XPV1 (1)"); + END IF; + + XPT1.VALU(I); + IF I /= IDENT_INT(1) THEN + FAILED ("INCORRECT RETURN VALUE OF XPT1.VALU (1)"); + END IF; + + PROC1(XPI1, XPA1, XPR1, XPP1, XPV1, XPT1); + + IF XPI1 /= IDENT_INT(2) THEN + FAILED ("INCORRECT VALUE OF XPI1 (2)"); + END IF; + + IF XPA1 /= (IDENT_INT(2),IDENT_INT(2),IDENT_INT(2)) THEN + FAILED ("INCORRECT VALUE OF XPA1 (2)"); + END IF; + + IF XPR1 /= (D => 1, FIELD1 => IDENT_INT(2)) THEN + FAILED ("INCORRECT VALUE OF XPR1 (2)"); + END IF; + + IF XPP1 /= IDENT(PP1) OR XPP1.ALL /= IDENT_INT(2) THEN + FAILED ("INCORRECT VALUE OF XPP1 (2)"); + END IF; + + IF PACK1."/=" (XPV1, PACK1.IDENT(PACK1.TWO)) THEN + FAILED ("INCORRECT VALUE OF XPV1 (2)"); + END IF; + + XPT1.VALU(I); + IF I /= IDENT_INT(2) THEN + FAILED ("INCORRECT RETURN VALUE FROM XPT1.VALU (2)"); + END IF; + + CHK_TASK.ENTRY1 (XPI1, XPA1, XPR1, XPP1, XPV1, XPT1); + + IF XPI1 /= IDENT_INT(3) THEN + FAILED ("INCORRECT VALUE OF XPI1 (3)"); + END IF; + + IF XPA1 /= (IDENT_INT(3),IDENT_INT(3),IDENT_INT(3)) THEN + FAILED ("INCORRECT VALUE OF XPA1 (3)"); + END IF; + + IF XPR1 /= (D => 1, FIELD1 => IDENT_INT(3)) THEN + FAILED ("INCORRECT VALUE OF XPR1 (3)"); + END IF; + + IF XPP1 /= IDENT(PP1) OR XPP1.ALL /= IDENT_INT(3) THEN + FAILED ("INCORRECT VALUE OF XPP1 (3)"); + END IF; + + IF PACK1."/=" (XPV1, PACK1.IDENT(PACK1.THREE)) THEN + FAILED ("INCORRECT VALUE OF XPV1 (3)"); + END IF; + + XPT1.VALU(I); + IF I /= IDENT_INT(3) THEN + FAILED ("INCORRECT RETURN VALUE OF XPT1.VALU (3)"); + END IF; + + XPI1 := XPI1 + 1; + XPA1 := (XPA1(1)+1, XPA1(2)+1, XPA1(3)+1); + XPR1 := (D => 1, FIELD1 => XPR1.FIELD1 + 1); + XPP1 := NEW INTEGER'(XPP1.ALL + 1); + XPV1 := PACK1.NEXT(XPV1); + XPT1.NEXT; + + IF XPI1 /= IDENT_INT(4) THEN + FAILED ("INCORRECT VALUE OF XPI1 (4)"); + END IF; + + IF XPA1 /= (IDENT_INT(4),IDENT_INT(4),IDENT_INT(4)) THEN + FAILED ("INCORRECT VALUE OF XPA1 (4)"); + END IF; + + IF XPR1 /= (D => 1, FIELD1 => IDENT_INT(4)) THEN + FAILED ("INCORRECT VALUE OF XPR1 (4)"); + END IF; + + IF XPP1 /= IDENT(PP1) OR XPP1.ALL /= IDENT_INT(4) THEN + FAILED ("INCORRECT VALUE OF XPP1 (4)"); + END IF; + + IF PACK1."/=" (XPV1, PACK1.IDENT(PACK1.FOUR)) THEN + FAILED ("INCORRECT VALUE OF XPV1 (4)"); + END IF; + + XPT1.VALU(I); + IF I /= IDENT_INT(4) THEN + FAILED ("INCORRECT RETURN VALUE OF XPT1.VALU (4)"); + END IF; + + PI1 := PI1 + 1; + PA1 := (PA1(1)+1, PA1(2)+1, PA1(3)+1); + PR1 := (D => 1, FIELD1 => PR1.FIELD1 + 1); + PP1 := NEW INTEGER'(PP1.ALL + 1); + PV1 := PACK1.NEXT(PV1); + PT1.NEXT; + + IF XPI1 /= IDENT_INT(5) THEN + FAILED ("INCORRECT VALUE OF XPI1 (5)"); + END IF; + + IF XPA1 /= (IDENT_INT(5),IDENT_INT(5),IDENT_INT(5)) THEN + FAILED ("INCORRECT VALUE OF XPA1 (5)"); + END IF; + + IF XPR1 /= (D => 1, FIELD1 => IDENT_INT(5)) THEN + FAILED ("INCORRECT VALUE OF XPR1 (5)"); + END IF; + + IF XPP1 /= IDENT(PP1) OR XPP1.ALL /= IDENT_INT(5) THEN + FAILED ("INCORRECT VALUE OF XPP1 (5)"); + END IF; + + IF PACK1."/=" (XPV1, PACK1.IDENT(PACK1.FIVE)) THEN + FAILED ("INCORRECT VALUE OF XPV1 (5)"); + END IF; + + XPT1.VALU(I); + IF I /= IDENT_INT(5) THEN + FAILED ("INCORRECT RETURN VALUE OF XPT1.VALU (5)"); + END IF; + END PROC; + +BEGIN + TEST ("C85005B", "CHECK THAT A VARIABLE CREATED BY A SUBPROGRAM " & + "'IN OUT' FORMAL PARAMETER CAN BE RENAMED " & + "AND HAS THE CORRECT VALUE, AND THAT THE NEW " & + "NAME CAN BE USED IN AN ASSIGNMENT STATEMENT " & + "AND PASSED ON AS AN ACTUAL SUBPROGRAM OR " & + "ENTRY 'IN OUT' OR 'OUT' PARAMETER, AND AS AN " & + "ACTUAL GENERIC 'IN OUT' PARAMETER, AND THAT " & + "WHEN THE VALUE OF THE RENAMED VARIABLE IS " & + "CHANGED, THE NEW VALUE IS REFLECTED BY THE " & + "VALUE OF THE NEW NAME"); + + PROC (DI1, DA1, DR1, DP1, DV1, DT1); + + DT1.STOP; + + RESULT; +END C85005B; diff --git a/gcc/testsuite/ada/acats/tests/c8/c85005c.ada b/gcc/testsuite/ada/acats/tests/c8/c85005c.ada new file mode 100644 index 000000000..fe2acb035 --- /dev/null +++ b/gcc/testsuite/ada/acats/tests/c8/c85005c.ada @@ -0,0 +1,416 @@ +-- C85005C.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 A VARIABLE CREATED BY AN ENTRY 'IN OUT' FORMAL +-- PARAMETER CAN BE RENAMED AND HAS THE CORRECT VALUE, AND THAT +-- THE NEW NAME CAN BE USED IN AN ASSIGNMENT STATEMENT AND PASSED +-- ON AS AN ACTUAL SUBPROGRAM OR ENTRY 'IN OUT' OR 'OUT' PARAMETER, +-- AND AS AN ACTUAL GENERIC 'IN OUT' PARAMETER, AND THAT WHEN THE +-- VALUE OF THE RENAMED VARIABLE IS CHANGED, THE NEW VALUE IS +-- REFLECTED BY THE VALUE OF THE NEW NAME. + +-- HISTORY: +-- JET 03/15/88 CREATED ORIGINAL TEST. + +WITH REPORT; USE REPORT; +PROCEDURE C85005C IS + + TYPE ARRAY1 IS ARRAY (POSITIVE RANGE <>) OF INTEGER; + TYPE RECORD1 (D : INTEGER) IS + RECORD + FIELD1 : INTEGER := 1; + END RECORD; + TYPE POINTER1 IS ACCESS INTEGER; + + PACKAGE PACK1 IS + TYPE PRIVY IS PRIVATE; + ZERO : CONSTANT PRIVY; + ONE : CONSTANT PRIVY; + TWO : CONSTANT PRIVY; + THREE : CONSTANT PRIVY; + FOUR : CONSTANT PRIVY; + FIVE : CONSTANT PRIVY; + FUNCTION IDENT (I : PRIVY) RETURN PRIVY; + FUNCTION NEXT (I : PRIVY) RETURN PRIVY; + PRIVATE + TYPE PRIVY IS RANGE 0..127; + ZERO : CONSTANT PRIVY := 0; + ONE : CONSTANT PRIVY := 1; + TWO : CONSTANT PRIVY := 2; + THREE : CONSTANT PRIVY := 3; + FOUR : CONSTANT PRIVY := 4; + FIVE : CONSTANT PRIVY := 5; + END PACK1; + + TASK TYPE TASK1 IS + ENTRY ASSIGN (J : IN INTEGER); + ENTRY VALU (J : OUT INTEGER); + ENTRY NEXT; + ENTRY STOP; + END TASK1; + + DI1 : INTEGER := 0; + DA1 : ARRAY1(1..3) := (OTHERS => 0); + DR1 : RECORD1(1) := (D => 1, FIELD1 => 0); + DP1 : POINTER1 := NEW INTEGER'(0); + DV1 : PACK1.PRIVY := PACK1.ZERO; + DT1 : TASK1; + + I : INTEGER; + + GENERIC + GI1 : IN OUT INTEGER; + GA1 : IN OUT ARRAY1; + GR1 : IN OUT RECORD1; + GP1 : IN OUT POINTER1; + GV1 : IN OUT PACK1.PRIVY; + GT1 : IN OUT TASK1; + PACKAGE GENERIC1 IS + END GENERIC1; + + FUNCTION IDENT (P : POINTER1) RETURN POINTER1 IS + BEGIN + IF EQUAL (3,3) THEN + RETURN P; + ELSE + RETURN NULL; + END IF; + END IDENT; + + PACKAGE BODY PACK1 IS + FUNCTION IDENT (I : PRIVY) RETURN PRIVY IS + BEGIN + IF EQUAL(3,3) THEN + RETURN I; + ELSE + RETURN PRIVY'(0); + END IF; + END IDENT; + + FUNCTION NEXT (I : PRIVY) RETURN PRIVY IS + BEGIN + RETURN I+1; + END NEXT; + END PACK1; + + PACKAGE BODY GENERIC1 IS + BEGIN + GI1 := GI1 + 1; + GA1 := (GA1(1)+1, GA1(2)+1, GA1(3)+1); + GR1 := (D => 1, FIELD1 => GR1.FIELD1 + 1); + GP1 := NEW INTEGER'(GP1.ALL + 1); + GV1 := PACK1.NEXT(GV1); + GT1.NEXT; + END GENERIC1; + + TASK BODY TASK1 IS + TASK_VALUE : INTEGER := 0; + ACCEPTING_ENTRIES : BOOLEAN := TRUE; + BEGIN + WHILE ACCEPTING_ENTRIES LOOP + SELECT + ACCEPT ASSIGN (J : IN INTEGER) DO + TASK_VALUE := J; + END ASSIGN; + OR + ACCEPT VALU (J : OUT INTEGER) DO + J := TASK_VALUE; + END VALU; + OR + ACCEPT NEXT DO + TASK_VALUE := TASK_VALUE + 1; + END NEXT; + OR + ACCEPT STOP DO + ACCEPTING_ENTRIES := FALSE; + END STOP; + END SELECT; + END LOOP; + END TASK1; + +BEGIN + TEST ("C85005C", "CHECK THAT A VARIABLE CREATED BY AN ENTRY " & + "'IN OUT' FORMAL PARAMETER CAN BE RENAMED " & + "AND HAS THE CORRECT VALUE, AND THAT THE NEW " & + "NAME CAN BE USED IN AN ASSIGNMENT STATEMENT " & + "AND PASSED ON AS AN ACTUAL SUBPROGRAM OR " & + "ENTRY 'IN OUT' OR 'OUT' PARAMETER, AND AS AN " & + "ACTUAL GENERIC 'IN OUT' PARAMETER, AND THAT " & + "WHEN THE VALUE OF THE RENAMED VARIABLE IS " & + "CHANGED, THE NEW VALUE IS REFLECTED BY THE " & + "VALUE OF THE NEW NAME"); + + DECLARE + TASK MAIN_TASK IS + ENTRY START (TI1 : IN OUT INTEGER; TA1 : IN OUT ARRAY1; + TR1 : IN OUT RECORD1; TP1 : IN OUT POINTER1; + TV1 : IN OUT PACK1.PRIVY; + TT1 : IN OUT TASK1); + END MAIN_TASK; + + TASK BODY MAIN_TASK IS + BEGIN + ACCEPT START (TI1: IN OUT INTEGER; TA1: IN OUT ARRAY1; + TR1: IN OUT RECORD1; TP1: IN OUT POINTER1; + TV1: IN OUT PACK1.PRIVY; + TT1: IN OUT TASK1) DO + DECLARE + XTI1 : INTEGER RENAMES TI1; + XTA1 : ARRAY1 RENAMES TA1; + XTR1 : RECORD1 RENAMES TR1; + XTP1 : POINTER1 RENAMES TP1; + XTV1 : PACK1.PRIVY RENAMES TV1; + XTT1 : TASK1 RENAMES TT1; + + TASK TYPE TASK2 IS + ENTRY ENTRY1 (TTI1 : OUT INTEGER; + TTA1 : OUT ARRAY1; + TTR1 : OUT RECORD1; + TTP1 : IN OUT POINTER1; + TTV1 : IN OUT PACK1.PRIVY; + TTT1 : IN OUT TASK1); + END TASK2; + + CHK_TASK : TASK2; + + PROCEDURE PROC1 (PTI1 : IN OUT INTEGER; + PTA1 : IN OUT ARRAY1; + PTR1 : IN OUT RECORD1; + PTP1 : OUT POINTER1; + PTV1 : OUT PACK1.PRIVY; + PTT1 : IN OUT TASK1) IS + BEGIN + PTI1 := PTI1 + 1; + PTA1 := (PTA1(1)+1, PTA1(2)+1, PTA1(3)+1); + PTR1 := (D => 1, + FIELD1 => PTR1.FIELD1 + 1); + PTP1 := NEW INTEGER'(TP1.ALL + 1); + PTV1 := PACK1.NEXT(TV1); + PTT1.NEXT; + END PROC1; + + TASK BODY TASK2 IS + BEGIN + ACCEPT ENTRY1 (TTI1 : OUT INTEGER; + TTA1 : OUT ARRAY1; + TTR1 : OUT RECORD1; + TTP1 : IN OUT POINTER1; + TTV1 : IN OUT PACK1.PRIVY; + TTT1 : IN OUT TASK1) + DO + TTI1 := TI1 + 1; + TTA1 := (TA1(1)+1, + TA1(2)+1, TA1(3)+1); + TTR1 := (D => 1, + FIELD1 => TR1.FIELD1 + 1); + TTP1 := NEW INTEGER'(TTP1.ALL + 1); + TTV1 := PACK1.NEXT(TTV1); + TTT1.NEXT; + END ENTRY1; + END TASK2; + + PACKAGE GENPACK1 IS NEW GENERIC1 + (XTI1, XTA1, XTR1, XTP1, XTV1, XTT1); + BEGIN + IF XTI1 /= IDENT_INT(1) THEN + FAILED ("INCORRECT VALUE OF XTI1 (1)"); + END IF; + + IF XTA1 /= (IDENT_INT(1),IDENT_INT(1), + IDENT_INT(1)) THEN + FAILED ("INCORRECT VALUE OF XTA1 (1)"); + END IF; + + IF XTR1 /= (D => 1, FIELD1 => IDENT_INT(1)) + THEN + FAILED ("INCORRECT VALUE OF XTR1 (1)"); + END IF; + + IF XTP1 /= IDENT(TP1) OR + XTP1.ALL /= IDENT_INT(1) THEN + FAILED ("INCORRECT VALUE OF XTP1 (1)"); + END IF; + + IF PACK1."/=" (XTV1, PACK1.IDENT(PACK1.ONE)) + THEN + FAILED ("INCORRECT VALUE OF XTV1 (1)"); + END IF; + + XTT1.VALU(I); + IF I /= IDENT_INT(1) THEN + FAILED ("INCORRECT RETURN VALUE OF " & + "XTT1.VALU (1)"); + END IF; + + PROC1(XTI1, XTA1, XTR1, XTP1, XTV1, XTT1); + + IF XTI1 /= IDENT_INT(2) THEN + FAILED ("INCORRECT VALUE OF XTI1 (2)"); + END IF; + + IF XTA1 /= (IDENT_INT(2),IDENT_INT(2), + IDENT_INT(2)) THEN + FAILED ("INCORRECT VALUE OF XTA1 (2)"); + END IF; + + IF XTR1 /= (D => 1, FIELD1 => IDENT_INT(2)) + THEN + FAILED ("INCORRECT VALUE OF XTR1 (2)"); + END IF; + + IF XTP1 /= IDENT(TP1) OR + XTP1.ALL /= IDENT_INT(2) THEN + FAILED ("INCORRECT VALUE OF XTP1 (2)"); + END IF; + + IF PACK1."/=" (XTV1, PACK1.IDENT(PACK1.TWO)) + THEN + FAILED ("INCORRECT VALUE OF XTV1 (2)"); + END IF; + + XTT1.VALU(I); + IF I /= IDENT_INT(2) THEN + FAILED ("INCORRECT RETURN VALUE FROM " & + "XTT1.VALU (2)"); + END IF; + + CHK_TASK.ENTRY1 + (XTI1, XTA1, XTR1, XTP1, XTV1, XTT1); + + IF XTI1 /= IDENT_INT(3) THEN + FAILED ("INCORRECT VALUE OF XTI1 (3)"); + END IF; + + IF XTA1 /= (IDENT_INT(3),IDENT_INT(3), + IDENT_INT(3)) THEN + FAILED ("INCORRECT VALUE OF XTA1 (3)"); + END IF; + + IF XTR1 /= (D => 1, FIELD1 => IDENT_INT(3)) + THEN + FAILED ("INCORRECT VALUE OF XTR1 (3)"); + END IF; + + IF XTP1 /= IDENT(TP1) OR + XTP1.ALL /= IDENT_INT(3) THEN + FAILED ("INCORRECT VALUE OF XTP1 (3)"); + END IF; + + IF PACK1."/=" (XTV1, PACK1.IDENT(PACK1.THREE)) + THEN + FAILED ("INCORRECT VALUE OF XTV1 (3)"); + END IF; + + XTT1.VALU(I); + IF I /= IDENT_INT(3) THEN + FAILED ("INCORRECT RETURN VALUE OF " & + "XTT1.VALU (3)"); + END IF; + + XTI1 := XTI1 + 1; + XTA1 := (XTA1(1)+1, XTA1(2)+1, XTA1(3)+1); + XTR1 := (D => 1, FIELD1 => XTR1.FIELD1 + 1); + XTP1 := NEW INTEGER'(XTP1.ALL + 1); + XTV1 := PACK1.NEXT(XTV1); + XTT1.NEXT; + + IF XTI1 /= IDENT_INT(4) THEN + FAILED ("INCORRECT VALUE OF XTI1 (4)"); + END IF; + + IF XTA1 /= (IDENT_INT(4),IDENT_INT(4), + IDENT_INT(4)) THEN + FAILED ("INCORRECT VALUE OF XTA1 (4)"); + END IF; + + IF XTR1 /= (D => 1, FIELD1 => IDENT_INT(4)) + THEN + FAILED ("INCORRECT VALUE OF XTR1 (4)"); + END IF; + + IF XTP1 /= IDENT(TP1) OR + XTP1.ALL /= IDENT_INT(4) THEN + FAILED ("INCORRECT VALUE OF XTP1 (4)"); + END IF; + + IF PACK1."/=" (XTV1, PACK1.IDENT(PACK1.FOUR)) + THEN + FAILED ("INCORRECT VALUE OF XTV1 (4)"); + END IF; + + XTT1.VALU(I); + IF I /= IDENT_INT(4) THEN + FAILED ("INCORRECT RETURN VALUE OF " & + "XTT1.VALU (4)"); + END IF; + + TI1 := TI1 + 1; + TA1 := (TA1(1)+1, TA1(2)+1, TA1(3)+1); + TR1 := (D => 1, FIELD1 => TR1.FIELD1 + 1); + TP1 := NEW INTEGER'(TP1.ALL + 1); + TV1 := PACK1.NEXT(TV1); + TT1.NEXT; + + IF XTI1 /= IDENT_INT(5) THEN + FAILED ("INCORRECT VALUE OF XTI1 (5)"); + END IF; + + IF XTA1 /= (IDENT_INT(5),IDENT_INT(5), + IDENT_INT(5)) THEN + FAILED ("INCORRECT VALUE OF XTA1 (5)"); + END IF; + + IF XTR1 /= (D => 1, FIELD1 => IDENT_INT(5)) + THEN + FAILED ("INCORRECT VALUE OF XTR1 (5)"); + END IF; + + IF XTP1 /= IDENT(TP1) OR + XTP1.ALL /= IDENT_INT(5) THEN + FAILED ("INCORRECT VALUE OF XTP1 (5)"); + END IF; + + IF PACK1."/=" (XTV1, PACK1.IDENT(PACK1.FIVE)) + THEN + FAILED ("INCORRECT VALUE OF XTV1 (5)"); + END IF; + + XTT1.VALU(I); + IF I /= IDENT_INT(5) THEN + FAILED ("INCORRECT RETURN VALUE OF " & + "XTT1.VALU (5)"); + END IF; + END; + END START; + END MAIN_TASK; + + BEGIN + MAIN_TASK.START (DI1, DA1, DR1, DP1, DV1, DT1); + END; + + DT1.STOP; + + RESULT; +END C85005C; diff --git a/gcc/testsuite/ada/acats/tests/c8/c85005d.ada b/gcc/testsuite/ada/acats/tests/c8/c85005d.ada new file mode 100644 index 000000000..c745aee44 --- /dev/null +++ b/gcc/testsuite/ada/acats/tests/c8/c85005d.ada @@ -0,0 +1,378 @@ +-- C85005D.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 A VARIABLE CREATED BY A GENERIC 'IN OUT' FORMAL +-- PARAMETER CAN BE RENAMED AND HAS THE CORRECT VALUE, AND +-- THAT THE NEW NAME CAN BE USED IN AN ASSIGNMENT STATEMENT AND +-- PASSED ON AS AN ACTUAL SUBPROGRAM OR ENTRY 'IN OUT' OR 'OUT' +-- PARAMETER, AND AS AN ACTUAL GENERIC 'IN OUT' PARAMETER, +-- AND THAT WHEN THE VALUE OF THE RENAMED VARIABLE IS CHANGED, +-- THE NEW VALUE IS REFLECTED BY THE VALUE OF THE NEW NAME. + +-- HISTORY: +-- JET 03/15/88 CREATED ORIGINAL TEST. + +WITH REPORT; USE REPORT; +PROCEDURE C85005D IS + + TYPE ARRAY1 IS ARRAY (POSITIVE RANGE <>) OF INTEGER; + TYPE RECORD1 (D : INTEGER) IS + RECORD + FIELD1 : INTEGER := 1; + END RECORD; + TYPE POINTER1 IS ACCESS INTEGER; + + PACKAGE PACK1 IS + TYPE PRIVY IS PRIVATE; + ZERO : CONSTANT PRIVY; + ONE : CONSTANT PRIVY; + TWO : CONSTANT PRIVY; + THREE : CONSTANT PRIVY; + FOUR : CONSTANT PRIVY; + FIVE : CONSTANT PRIVY; + FUNCTION IDENT (I : PRIVY) RETURN PRIVY; + FUNCTION NEXT (I : PRIVY) RETURN PRIVY; + PRIVATE + TYPE PRIVY IS RANGE 0..127; + ZERO : CONSTANT PRIVY := 0; + ONE : CONSTANT PRIVY := 1; + TWO : CONSTANT PRIVY := 2; + THREE : CONSTANT PRIVY := 3; + FOUR : CONSTANT PRIVY := 4; + FIVE : CONSTANT PRIVY := 5; + END PACK1; + + TASK TYPE TASK1 IS + ENTRY ASSIGN (J : IN INTEGER); + ENTRY VALU (J : OUT INTEGER); + ENTRY NEXT; + ENTRY STOP; + END TASK1; + + DI1 : INTEGER := 0; + DA1 : ARRAY1(1..3) := (OTHERS => 0); + DR1 : RECORD1(1) := (D => 1, FIELD1 => 0); + DP1 : POINTER1 := NEW INTEGER'(0); + DV1 : PACK1.PRIVY := PACK1.ZERO; + DT1 : TASK1; + + I : INTEGER; + + GENERIC + GI1 : IN OUT INTEGER; + GA1 : IN OUT ARRAY1; + GR1 : IN OUT RECORD1; + GP1 : IN OUT POINTER1; + GV1 : IN OUT PACK1.PRIVY; + GT1 : IN OUT TASK1; + PACKAGE GENERIC1 IS + END GENERIC1; + + FUNCTION IDENT (P : POINTER1) RETURN POINTER1 IS + BEGIN + IF EQUAL (3,3) THEN + RETURN P; + ELSE + RETURN NULL; + END IF; + END IDENT; + + PACKAGE BODY PACK1 IS + FUNCTION IDENT (I : PRIVY) RETURN PRIVY IS + BEGIN + IF EQUAL(3,3) THEN + RETURN I; + ELSE + RETURN PRIVY'(0); + END IF; + END IDENT; + + FUNCTION NEXT (I : PRIVY) RETURN PRIVY IS + BEGIN + RETURN I+1; + END NEXT; + END PACK1; + + PACKAGE BODY GENERIC1 IS + XGI1 : INTEGER RENAMES GI1; + XGA1 : ARRAY1 RENAMES GA1; + XGR1 : RECORD1 RENAMES GR1; + XGP1 : POINTER1 RENAMES GP1; + XGV1 : PACK1.PRIVY RENAMES GV1; + XGT1 : TASK1 RENAMES GT1; + + TASK TYPE TASK2 IS + ENTRY ENTRY1 (TI1 : OUT INTEGER; TA1 : OUT ARRAY1; + TR1 : OUT RECORD1; TP1 : IN OUT POINTER1; + TV1 : IN OUT PACK1.PRIVY; + TT1 : IN OUT TASK1); + END TASK2; + + G_CHK_TASK : TASK2; + + GENERIC + GGI1 : IN OUT INTEGER; + GGA1 : IN OUT ARRAY1; + GGR1 : IN OUT RECORD1; + GGP1 : IN OUT POINTER1; + GGV1 : IN OUT PACK1.PRIVY; + GGT1 : IN OUT TASK1; + PACKAGE GENERIC2 IS + END GENERIC2; + + PACKAGE BODY GENERIC2 IS + BEGIN + GGI1 := GGI1 + 1; + GGA1 := (GGA1(1)+1, GGA1(2)+1, GGA1(3)+1); + GGR1 := (D => 1, FIELD1 => GGR1.FIELD1 + 1); + GGP1 := NEW INTEGER'(GGP1.ALL + 1); + GGV1 := PACK1.NEXT(GGV1); + GGT1.NEXT; + END GENERIC2; + + TASK BODY TASK2 IS + BEGIN + ACCEPT ENTRY1 (TI1 : OUT INTEGER; TA1 : OUT ARRAY1; + TR1 : OUT RECORD1; TP1 : IN OUT POINTER1; + TV1 : IN OUT PACK1.PRIVY; + TT1 : IN OUT TASK1) + DO + TI1 := GI1 + 1; + TA1 := (GA1(1)+1, GA1(2)+1, GA1(3)+1); + TR1 := (D => 1, FIELD1 => GR1.FIELD1 + 1); + TP1 := NEW INTEGER'(TP1.ALL + 1); + TV1 := PACK1.NEXT(TV1); + TT1.NEXT; + END ENTRY1; + END TASK2; + + PROCEDURE PROC1 (PI1 : IN OUT INTEGER; PA1 : IN OUT ARRAY1; + PR1 : IN OUT RECORD1; PP1 : OUT POINTER1; + PV1 : OUT PACK1.PRIVY; PT1 : IN OUT TASK1) IS + BEGIN + PI1 := PI1 + 1; + PA1 := (PA1(1)+1, PA1(2)+1, PA1(3)+1); + PR1 := (D => 1, FIELD1 => PR1.FIELD1 + 1); + PP1 := NEW INTEGER'(GP1.ALL + 1); + PV1 := PACK1.NEXT(GV1); + PT1.NEXT; + END PROC1; + + PACKAGE GENPACK2 IS NEW GENERIC2 + (XGI1, XGA1, XGR1, XGP1, XGV1, XGT1); + + BEGIN + IF XGI1 /= IDENT_INT(1) THEN + FAILED ("INCORRECT VALUE OF XGI1 (1)"); + END IF; + + IF XGA1 /= (IDENT_INT(1),IDENT_INT(1),IDENT_INT(1)) THEN + FAILED ("INCORRECT VALUE OF XGA1 (1)"); + END IF; + + IF XGR1 /= (D => 1, FIELD1 => IDENT_INT(1)) THEN + FAILED ("INCORRECT VALUE OF XGR1 (1)"); + END IF; + + IF XGP1 /= IDENT(GP1) OR XGP1.ALL /= IDENT_INT(1) THEN + FAILED ("INCORRECT VALUE OF XGP1 (1)"); + END IF; + + IF PACK1."/=" (XGV1, PACK1.IDENT(PACK1.ONE)) THEN + FAILED ("INCORRECT VALUE OF XGV1 (1)"); + END IF; + + XGT1.VALU(I); + IF I /= IDENT_INT(1) THEN + FAILED ("INCORRECT RETURN VALUE OF XGT1.VALU (1)"); + END IF; + + PROC1(XGI1, XGA1, XGR1, XGP1, XGV1, XGT1); + + IF XGI1 /= IDENT_INT(2) THEN + FAILED ("INCORRECT VALUE OF XGI1 (2)"); + END IF; + + IF XGA1 /= (IDENT_INT(2),IDENT_INT(2),IDENT_INT(2)) THEN + FAILED ("INCORRECT VALUE OF XGA1 (2)"); + END IF; + + IF XGR1 /= (D => 1, FIELD1 => IDENT_INT(2)) THEN + FAILED ("INCORRECT VALUE OF XGR1 (2)"); + END IF; + + IF XGP1 /= IDENT(GP1) OR XGP1.ALL /= IDENT_INT(2) THEN + FAILED ("INCORRECT VALUE OF XGP1 (2)"); + END IF; + + IF PACK1."/=" (XGV1, PACK1.IDENT(PACK1.TWO)) THEN + FAILED ("INCORRECT VALUE OF XGV1 (2)"); + END IF; + + XGT1.VALU(I); + IF I /= IDENT_INT(2) THEN + FAILED ("INCORRECT RETURN VALUE OF XGT1.VALU (2)"); + END IF; + + G_CHK_TASK.ENTRY1(XGI1, XGA1, XGR1, XGP1, XGV1, XGT1); + + IF XGI1 /= IDENT_INT(3) THEN + FAILED ("INCORRECT VALUE OF XGI1 (3)"); + END IF; + + IF XGA1 /= (IDENT_INT(3),IDENT_INT(3),IDENT_INT(3)) THEN + FAILED ("INCORRECT VALUE OF XGA1 (3)"); + END IF; + + IF XGR1 /= (D => 1, FIELD1 => IDENT_INT(3)) THEN + FAILED ("INCORRECT VALUE OF XGR1 (3)"); + END IF; + + IF XGP1 /= IDENT(GP1) OR XGP1.ALL /= IDENT_INT(3) THEN + FAILED ("INCORRECT VALUE OF XGP1 (3)"); + END IF; + + IF PACK1."/=" (XGV1, PACK1.IDENT(PACK1.THREE)) THEN + FAILED ("INCORRECT VALUE OF XGV1 (3)"); + END IF; + + XGT1.VALU(I); + IF I /= IDENT_INT(3) THEN + FAILED ("INCORRECT RETURN VALUE OF XGT1.VALU (3)"); + END IF; + + XGI1 := XGI1 + 1; + XGA1 := (XGA1(1)+1, XGA1(2)+1, XGA1(3)+1); + XGR1 := (D => 1, FIELD1 => XGR1.FIELD1 + 1); + XGP1 := NEW INTEGER'(XGP1.ALL + 1); + XGV1 := PACK1.NEXT(XGV1); + XGT1.NEXT; + + IF XGI1 /= IDENT_INT(4) THEN + FAILED ("INCORRECT VALUE OF XGI1 (4)"); + END IF; + + IF XGA1 /= (IDENT_INT(4),IDENT_INT(4),IDENT_INT(4)) THEN + FAILED ("INCORRECT VALUE OF XGA1 (4)"); + END IF; + + IF XGR1 /= (D => 1, FIELD1 => IDENT_INT(4)) THEN + FAILED ("INCORRECT VALUE OF XGR1 (4)"); + END IF; + + IF XGP1 /= IDENT(GP1) OR XGP1.ALL /= IDENT_INT(4) THEN + FAILED ("INCORRECT VALUE OF XGP1 (4)"); + END IF; + + IF PACK1."/=" (XGV1, PACK1.IDENT(PACK1.FOUR)) THEN + FAILED ("INCORRECT VALUE OF XGV1 (4)"); + END IF; + + XGT1.VALU(I); + IF I /= IDENT_INT(4) THEN + FAILED ("INCORRECT RETURN VALUE OF XGT1.VALU (4)"); + END IF; + + GI1 := GI1 + 1; + GA1 := (GA1(1)+1, GA1(2)+1, GA1(3)+1); + GR1 := (D => 1, FIELD1 => GR1.FIELD1 + 1); + GP1 := NEW INTEGER'(GP1.ALL + 1); + GV1 := PACK1.NEXT(GV1); + GT1.NEXT; + + IF XGI1 /= IDENT_INT(5) THEN + FAILED ("INCORRECT VALUE OF XGI1 (5)"); + END IF; + + IF XGA1 /= (IDENT_INT(5),IDENT_INT(5),IDENT_INT(5)) THEN + FAILED ("INCORRECT VALUE OF XGA1 (5)"); + END IF; + + IF XGR1 /= (D => 1, FIELD1 => IDENT_INT(5)) THEN + FAILED ("INCORRECT VALUE OF XGR1 (5)"); + END IF; + + IF XGP1 /= IDENT(GP1) OR XGP1.ALL /= IDENT_INT(5) THEN + FAILED ("INCORRECT VALUE OF XGP1 (5)"); + END IF; + + IF PACK1."/=" (XGV1, PACK1.IDENT(PACK1.FIVE)) THEN + FAILED ("INCORRECT VALUE OF XGV1 (5)"); + END IF; + + XGT1.VALU(I); + IF I /= IDENT_INT(5) THEN + FAILED ("INCORRECT RETURN VALUE OF XGT1.VALU (5)"); + END IF; + END GENERIC1; + + TASK BODY TASK1 IS + TASK_VALUE : INTEGER := 0; + ACCEPTING_ENTRIES : BOOLEAN := TRUE; + BEGIN + WHILE ACCEPTING_ENTRIES LOOP + SELECT + ACCEPT ASSIGN (J : IN INTEGER) DO + TASK_VALUE := J; + END ASSIGN; + OR + ACCEPT VALU (J : OUT INTEGER) DO + J := TASK_VALUE; + END VALU; + OR + ACCEPT NEXT DO + TASK_VALUE := TASK_VALUE + 1; + END NEXT; + OR + ACCEPT STOP DO + ACCEPTING_ENTRIES := FALSE; + END STOP; + END SELECT; + END LOOP; + END TASK1; + +BEGIN + TEST ("C85005D", "CHECK THAT A VARIABLE CREATED BY A GENERIC " & + "'IN OUT' FORMAL PARAMETER CAN BE RENAMED " & + "AND HAS THE CORRECT VALUE, AND THAT THE NEW " & + "NAME CAN BE USED IN AN ASSIGNMENT STATEMENT " & + "AND PASSED ON AS AN ACTUAL SUBPROGRAM OR " & + "ENTRY 'IN OUT' OR 'OUT' PARAMETER, AND AS AN " & + "ACTUAL GENERIC 'IN OUT' PARAMETER, AND THAT " & + "WHEN THE VALUE OF THE RENAMED VARIABLE IS " & + "CHANGED, THE NEW VALUE IS REFLECTED BY THE " & + "VALUE OF THE NEW NAME"); + + DECLARE + PACKAGE GENPACK1 IS NEW + GENERIC1 (DI1, DA1, DR1, DP1, DV1, DT1); + BEGIN + NULL; + END; + + DT1.STOP; + + RESULT; +END C85005D; diff --git a/gcc/testsuite/ada/acats/tests/c8/c85005e.ada b/gcc/testsuite/ada/acats/tests/c8/c85005e.ada new file mode 100644 index 000000000..1f6ffc37d --- /dev/null +++ b/gcc/testsuite/ada/acats/tests/c8/c85005e.ada @@ -0,0 +1,397 @@ +-- C85005E.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 A VARIABLE CREATED BY AN ALLOCATOR CAN BE RENAMED AND +-- HAS THE CORRECT VALUE, AND THAT THE NEW NAME CAN BE USED IN AN +-- ASSIGNMENT STATEMENT AND PASSED ON AS AN ACTUAL SUBPROGRAM OR +-- ENTRY 'IN OUT' OR 'OUT' PARAMETER, AND AS AN ACTUAL GENERIC +-- 'IN OUT' PARAMETER, AND THAT WHEN THE VALUE OF THE RENAMED +-- VARIABLE IS CHANGED, THE NEW VALUE IS REFLECTED BY THE VALUE OF +-- THE NEW NAME. + +-- HISTORY: +-- JET 03/15/88 CREATED ORIGINAL TEST. + +WITH REPORT; USE REPORT; +PROCEDURE C85005E IS + + TYPE ARRAY1 IS ARRAY (POSITIVE RANGE <>) OF INTEGER; + TYPE RECORD1 (D : INTEGER) IS + RECORD + FIELD1 : INTEGER := 1; + END RECORD; + TYPE POINTER1 IS ACCESS INTEGER; + + PACKAGE PACK1 IS + TYPE PACKACC IS ACCESS INTEGER; + AK1 : PACKACC := NEW INTEGER'(0); + TYPE PRIVY IS PRIVATE; + ZERO : CONSTANT PRIVY; + ONE : CONSTANT PRIVY; + TWO : CONSTANT PRIVY; + THREE : CONSTANT PRIVY; + FOUR : CONSTANT PRIVY; + FIVE : CONSTANT PRIVY; + FUNCTION IDENT (I : PRIVY) RETURN PRIVY; + FUNCTION NEXT (I : PRIVY) RETURN PRIVY; + PRIVATE + TYPE PRIVY IS RANGE 0..127; + ZERO : CONSTANT PRIVY := 0; + ONE : CONSTANT PRIVY := 1; + TWO : CONSTANT PRIVY := 2; + THREE : CONSTANT PRIVY := 3; + FOUR : CONSTANT PRIVY := 4; + FIVE : CONSTANT PRIVY := 5; + END PACK1; + + TASK TYPE TASK1 IS + ENTRY ASSIGN (J : IN INTEGER); + ENTRY VALU (J : OUT INTEGER); + ENTRY NEXT; + ENTRY STOP; + END TASK1; + + GENERIC + GI1 : IN OUT INTEGER; + GA1 : IN OUT ARRAY1; + GR1 : IN OUT RECORD1; + GP1 : IN OUT POINTER1; + GV1 : IN OUT PACK1.PRIVY; + GT1 : IN OUT TASK1; + GK1 : IN OUT INTEGER; + PACKAGE GENERIC1 IS + END GENERIC1; + + FUNCTION IDENT (P : POINTER1) RETURN POINTER1 IS + BEGIN + IF EQUAL (3,3) THEN + RETURN P; + ELSE + RETURN NULL; + END IF; + END IDENT; + + PACKAGE BODY PACK1 IS + FUNCTION IDENT (I : PRIVY) RETURN PRIVY IS + BEGIN + IF EQUAL(3,3) THEN + RETURN I; + ELSE + RETURN PRIVY'(0); + END IF; + END IDENT; + + FUNCTION NEXT (I : PRIVY) RETURN PRIVY IS + BEGIN + RETURN I+1; + END NEXT; + END PACK1; + + PACKAGE BODY GENERIC1 IS + BEGIN + GI1 := GI1 + 1; + GA1 := (GA1(1)+1, GA1(2)+1, GA1(3)+1); + GR1 := (D => 1, FIELD1 => GR1.FIELD1 + 1); + GP1 := NEW INTEGER'(GP1.ALL + 1); + GV1 := PACK1.NEXT(GV1); + GT1.NEXT; + GK1 := GK1 + 1; + END GENERIC1; + + TASK BODY TASK1 IS + TASK_VALUE : INTEGER := 0; + ACCEPTING_ENTRIES : BOOLEAN := TRUE; + BEGIN + WHILE ACCEPTING_ENTRIES LOOP + SELECT + ACCEPT ASSIGN (J : IN INTEGER) DO + TASK_VALUE := J; + END ASSIGN; + OR + ACCEPT VALU (J : OUT INTEGER) DO + J := TASK_VALUE; + END VALU; + OR + ACCEPT NEXT DO + TASK_VALUE := TASK_VALUE + 1; + END NEXT; + OR + ACCEPT STOP DO + ACCEPTING_ENTRIES := FALSE; + END STOP; + END SELECT; + END LOOP; + END TASK1; + +BEGIN + TEST ("C85005E", "CHECK THAT A VARIABLE CREATED BY AN ALLOCATOR " & + "CAN BE RENAMED AND HAS THE CORRECT VALUE, AND " & + "THAT THE NEW NAME CAN BE USED IN AN ASSIGNMENT" & + " STATEMENT AND PASSED ON AS AN ACTUAL " & + "SUBPROGRAM OR ENTRY 'IN OUT' OR 'OUT' " & + "PARAMETER, AND AS AN ACTUAL GENERIC 'IN OUT' " & + "PARAMETER, AND THAT WHEN THE VALUE OF THE " & + "RENAMED VARIABLE IS CHANGED, THE NEW VALUE " & + "IS REFLECTED BY THE VALUE OF THE NEW NAME"); + + DECLARE + TYPE ACCINT IS ACCESS INTEGER; + TYPE ACCARR IS ACCESS ARRAY1; + TYPE ACCREC IS ACCESS RECORD1; + TYPE ACCPTR IS ACCESS POINTER1; + TYPE ACCPVT IS ACCESS PACK1.PRIVY; + TYPE ACCTSK IS ACCESS TASK1; + + AI1 : ACCINT := NEW INTEGER'(0); + AA1 : ACCARR := NEW ARRAY1'(0, 0, 0); + AR1 : ACCREC := NEW RECORD1'(D => 1, FIELD1 => 0); + AP1 : ACCPTR := NEW POINTER1'(NEW INTEGER'(0)); + AV1 : ACCPVT := NEW PACK1.PRIVY'(PACK1.ZERO); + AT1 : ACCTSK := NEW TASK1; + + XAI1 : INTEGER RENAMES AI1.ALL; + XAA1 : ARRAY1 RENAMES AA1.ALL; + XAR1 : RECORD1 RENAMES AR1.ALL; + XAP1 : POINTER1 RENAMES AP1.ALL; + XAV1 : PACK1.PRIVY RENAMES AV1.ALL; + XAK1 : INTEGER RENAMES PACK1.AK1.ALL; + XAT1 : TASK1 RENAMES AT1.ALL; + + TASK TYPE TASK2 IS + ENTRY ENTRY1 (TI1 : OUT INTEGER; TA1 : OUT ARRAY1; + TR1 : OUT RECORD1; TP1 : IN OUT POINTER1; + TV1 : IN OUT PACK1.PRIVY; + TT1 : IN OUT TASK1; TK1 : IN OUT INTEGER); + END TASK2; + + I : INTEGER; + A_CHK_TASK : TASK2; + + PROCEDURE PROC1 (PI1 : IN OUT INTEGER; PA1 : IN OUT ARRAY1; + PR1 : IN OUT RECORD1; PP1 : OUT POINTER1; + PV1 : OUT PACK1.PRIVY; PT1 : IN OUT TASK1; + PK1 : OUT INTEGER) IS + + BEGIN + PI1 := PI1 + 1; + PA1 := (PA1(1)+1, PA1(2)+1, PA1(3)+1); + PR1 := (D => 1, FIELD1 => PR1.FIELD1 + 1); + PP1 := NEW INTEGER'(AP1.ALL.ALL + 1); + PV1 := PACK1.NEXT(AV1.ALL); + PT1.NEXT; + PK1 := PACK1.AK1.ALL + 1; + END PROC1; + + TASK BODY TASK2 IS + BEGIN + ACCEPT ENTRY1 (TI1 : OUT INTEGER; TA1 : OUT ARRAY1; + TR1 : OUT RECORD1; TP1 : IN OUT POINTER1; + TV1 : IN OUT PACK1.PRIVY; + TT1 : IN OUT TASK1; + TK1 : IN OUT INTEGER) DO + TI1 := AI1.ALL + 1; + TA1 := (AA1.ALL(1)+1, AA1.ALL(2)+1, AA1.ALL(3)+1); + TR1 := (D => 1, FIELD1 => AR1.ALL.FIELD1 + 1); + TP1 := NEW INTEGER'(TP1.ALL + 1); + TV1 := PACK1.NEXT(TV1); + TT1.NEXT; + TK1 := TK1 + 1; + END ENTRY1; + END TASK2; + + PACKAGE GENPACK2 IS NEW + GENERIC1 (XAI1, XAA1, XAR1, XAP1, XAV1, XAT1, XAK1); + + BEGIN + IF XAI1 /= IDENT_INT(1) THEN + FAILED ("INCORRECT VALUE OF XAI1 (1)"); + END IF; + + IF XAA1 /= (IDENT_INT(1),IDENT_INT(1),IDENT_INT(1)) THEN + FAILED ("INCORRECT VALUE OF XAA1 (1)"); + END IF; + + IF XAR1 /= (D => 1, FIELD1 => IDENT_INT(1)) THEN + FAILED ("INCORRECT VALUE OF XAR1 (1)"); + END IF; + + IF XAP1 /= IDENT(AP1.ALL) OR XAP1.ALL /= IDENT_INT(1) THEN + FAILED ("INCORRECT VALUE OF XAP1 (1)"); + END IF; + + IF PACK1."/=" (XAV1, PACK1.IDENT(PACK1.ONE)) THEN + FAILED ("INCORRECT VALUE OF XAV1 (1)"); + END IF; + + XAT1.VALU(I); + IF I /= IDENT_INT(1) THEN + FAILED ("INCORRECT RETURN VALUE OF XAT1.VALU (1)"); + END IF; + + IF XAK1 /= IDENT_INT(1) THEN + FAILED ("INCORRECT VALUE OF XAK1 (1)"); + END IF; + + PROC1(XAI1, XAA1, XAR1, XAP1, XAV1, XAT1, XAK1); + + IF XAI1 /= IDENT_INT(2) THEN + FAILED ("INCORRECT VALUE OF XAI1 (2)"); + END IF; + + IF XAA1 /= (IDENT_INT(2),IDENT_INT(2),IDENT_INT(2)) THEN + FAILED ("INCORRECT VALUE OF XAA1 (2)"); + END IF; + + IF XAR1 /= (D => 1, FIELD1 => IDENT_INT(2)) THEN + FAILED ("INCORRECT VALUE OF XAR1 (2)"); + END IF; + + IF XAP1 /= IDENT(AP1.ALL) OR XAP1.ALL /= IDENT_INT(2) THEN + FAILED ("INCORRECT VALUE OF XAP1 (2)"); + END IF; + + IF PACK1."/=" (XAV1, PACK1.IDENT(PACK1.TWO)) THEN + FAILED ("INCORRECT VALUE OF XAV1 (2)"); + END IF; + + XAT1.VALU(I); + IF I /= IDENT_INT(2) THEN + FAILED ("INCORRECT RETURN VALUE OF XAT1.VALU (2)"); + END IF; + + IF XAK1 /= IDENT_INT(2) THEN + FAILED ("INCORRECT VALUE OF XAK1 (2)"); + END IF; + + A_CHK_TASK.ENTRY1(XAI1, XAA1, XAR1, XAP1, XAV1, XAT1, XAK1); + + IF XAI1 /= IDENT_INT(3) THEN + FAILED ("INCORRECT VALUE OF XAI1 (3)"); + END IF; + + IF XAA1 /= (IDENT_INT(3),IDENT_INT(3),IDENT_INT(3)) THEN + FAILED ("INCORRECT VALUE OF XAA1 (3)"); + END IF; + + IF XAR1 /= (D => 1, FIELD1 => IDENT_INT(3)) THEN + FAILED ("INCORRECT VALUE OF XAR1 (3)"); + END IF; + + IF XAP1 /= IDENT(AP1.ALL) OR XAP1.ALL /= IDENT_INT(3) THEN + FAILED ("INCORRECT VALUE OF XAP1 (3)"); + END IF; + + IF PACK1."/=" (XAV1, PACK1.IDENT(PACK1.THREE)) THEN + FAILED ("INCORRECT VALUE OF XAV1 (3)"); + END IF; + + XAT1.VALU(I); + IF I /= IDENT_INT(3) THEN + FAILED ("INCORRECT RETURN VALUE OF XAT1.VALU (3)"); + END IF; + + IF XAK1 /= IDENT_INT(3) THEN + FAILED ("INCORRECT VALUE OF XAK1 (3)"); + END IF; + + XAI1 := XAI1 + 1; + XAA1 := (XAA1(1)+1, XAA1(2)+1, XAA1(3)+1); + XAR1 := (D => 1, FIELD1 => XAR1.FIELD1 + 1); + XAP1 := NEW INTEGER'(XAP1.ALL + 1); + XAV1 := PACK1.NEXT(XAV1); + XAT1.NEXT; + XAK1 := XAK1 + 1; + + IF XAI1 /= IDENT_INT(4) THEN + FAILED ("INCORRECT VALUE OF XAI1 (4)"); + END IF; + + IF XAA1 /= (IDENT_INT(4),IDENT_INT(4),IDENT_INT(4)) THEN + FAILED ("INCORRECT VALUE OF XAA1 (4)"); + END IF; + + IF XAR1 /= (D => 1, FIELD1 => IDENT_INT(4)) THEN + FAILED ("INCORRECT VALUE OF XAR1 (4)"); + END IF; + + IF XAP1 /= IDENT(AP1.ALL) OR XAP1.ALL /= IDENT_INT(4) THEN + FAILED ("INCORRECT VALUE OF XAP1 (4)"); + END IF; + + IF PACK1."/=" (XAV1, PACK1.IDENT(PACK1.FOUR)) THEN + FAILED ("INCORRECT VALUE OF XAV1 (4)"); + END IF; + + XAT1.VALU(I); + IF I /= IDENT_INT(4) THEN + FAILED ("INCORRECT RETURN VALUE OF XAT1.VALU (4)"); + END IF; + + IF XAK1 /= IDENT_INT(4) THEN + FAILED ("INCORRECT VALUE OF XAK1 (4)"); + END IF; + + AI1.ALL := AI1.ALL + 1; + AA1.ALL := (AA1.ALL(1)+1, AA1.ALL(2)+1, AA1.ALL(3)+1); + AR1.ALL := (D => 1, FIELD1 => AR1.ALL.FIELD1 + 1); + AP1.ALL := NEW INTEGER'(AP1.ALL.ALL + 1); + AV1.ALL := PACK1.NEXT(AV1.ALL); + AT1.NEXT; + PACK1.AK1.ALL := PACK1.AK1.ALL + 1; + + IF XAI1 /= IDENT_INT(5) THEN + FAILED ("INCORRECT VALUE OF XAI1 (5)"); + END IF; + + IF XAA1 /= (IDENT_INT(5),IDENT_INT(5),IDENT_INT(5)) THEN + FAILED ("INCORRECT VALUE OF XAA1 (5)"); + END IF; + + IF XAR1 /= (D => 1, FIELD1 => IDENT_INT(5)) THEN + FAILED ("INCORRECT VALUE OF XAR1 (5)"); + END IF; + + IF XAP1 /= IDENT(AP1.ALL) OR XAP1.ALL /= IDENT_INT(5) THEN + FAILED ("INCORRECT VALUE OF XAP1 (5)"); + END IF; + + IF PACK1."/=" (XAV1, PACK1.IDENT(PACK1.FIVE)) THEN + FAILED ("INCORRECT VALUE OF XAV1 (5)"); + END IF; + + XAT1.VALU(I); + IF I /= IDENT_INT(5) THEN + FAILED ("INCORRECT RETURN VALUE OF XAT1.VALU (5)"); + END IF; + + IF XAK1 /= IDENT_INT(5) THEN + FAILED ("INCORRECT VALUE OF XAK1 (5)"); + END IF; + + AT1.STOP; + END; + + RESULT; +END C85005E; diff --git a/gcc/testsuite/ada/acats/tests/c8/c85005f.ada b/gcc/testsuite/ada/acats/tests/c8/c85005f.ada new file mode 100644 index 000000000..adc87f996 --- /dev/null +++ b/gcc/testsuite/ada/acats/tests/c8/c85005f.ada @@ -0,0 +1,71 @@ +-- C85005F.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 A RENAMED VARIABLE DESIGNATED BY AN ACCESS VALUE, +-- A CHANGE IN THE ACCESS VALUE DOES NOT AFFECT WHICH VARIABLE IS +-- DENOTED BY THE NEW NAME. + +-- HISTORY: +-- JET 07/26/88 CREATED ORIGINAL TEST. + +WITH REPORT; USE REPORT; +PROCEDURE C85005F IS + TYPE ACC IS ACCESS INTEGER; + + BUMP : INTEGER := 0; + + A : ACC := NULL; + + FUNCTION GET_POINTER RETURN ACC IS + BEGIN + BUMP := IDENT_INT(BUMP) + 1; + RETURN NEW INTEGER'(BUMP); + END GET_POINTER; + +BEGIN + TEST ("C85005F", "CHECK THAT, FOR A RENAMED VARIABLE DESIGNATED " & + "BY AN ACCESS VALUE, A CHANGE IN THE ACCESS " & + "VALUE DOES NOT AFFECT WHICH VARIABLE IS " & + "DENOTED BY THE NEW NAME"); + + A := GET_POINTER; + + DECLARE + X1 : INTEGER RENAMES A.ALL; + X2 : INTEGER RENAMES GET_POINTER.ALL; + BEGIN + A := GET_POINTER; + + IF X1 /= 1 THEN + FAILED("CHANGING ACCESS VALUE CHANGED RENAMED VARIABLE"); + END IF; + + IF X2 /= 2 THEN + FAILED("INCORRECT RESULT FROM FUNCTION AS PREFIX"); + END IF; + END; + + RESULT; +END C85005F; diff --git a/gcc/testsuite/ada/acats/tests/c8/c85005g.ada b/gcc/testsuite/ada/acats/tests/c8/c85005g.ada new file mode 100644 index 000000000..2c1f7f02a --- /dev/null +++ b/gcc/testsuite/ada/acats/tests/c8/c85005g.ada @@ -0,0 +1,145 @@ +-- C85005G.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 ANY SUBTYPE CONSTRAINT IMPOSED BY THE TYPE MARK USED +-- IN THE RENAMING DECLARATION IS IGNORED, AND THE SUBTYPE +-- CONSTRAINT ASSOCIATED WITH THE RENAMED VARIABLE IS USED INSTEAD. + +-- *** 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 + +-- HISTORY: +-- JET 07/26/88 CREATED ORIGINAL TEST. +-- MRM 03/30/93 REMOVED NUMERIC_ERROR FOR 9X COMPATIBILITY + +WITH REPORT; USE REPORT; +PROCEDURE C85005G IS + + SUBTYPE INT IS INTEGER RANGE -100 .. 100; + + I : INTEGER := IDENT_INT(INTEGER'LAST); + J : INT := IDENT_INT(INT'LAST); + + DG1 : INTEGER := IDENT_INT(INTEGER'LAST); + DG2 : INT := IDENT_INT(INT'LAST); + + XI : INT RENAMES I; + XJ : INTEGER RENAMES J; + + GENERIC + G1 : IN OUT INT; + G2 : IN OUT INTEGER; + PROCEDURE GEN; + + PROCEDURE GEN IS + XG1 : INT RENAMES G1; + XG2 : INTEGER RENAMES G2; + BEGIN + IF XG1 /= INTEGER'LAST THEN + FAILED("INCORRECT VALUE OF RENAMING VARIABLE - G1"); + END IF; + + XG1 := IDENT_INT(INTEGER'FIRST); + + IF XG1 /= INTEGER'FIRST THEN + FAILED("INCORRECT VALUE OF RENAMING VARIABLE - G2"); + END IF; + + IF XG2 /= INT'LAST THEN + FAILED("INCORRECT VALUE OF RENAMING VARIABLE - G3"); + END IF; + + XG2 := IDENT_INT(INT'FIRST); + + IF XG2 /= INT'FIRST THEN + FAILED("INCORRECT VALUE OF RENAMING VARIABLE - G4"); + END IF; + + BEGIN + XG2 := IDENT_INT(INTEGER'LAST); + FAILED ("NO EXCEPTION RAISED BY XG2 := INTEGER'LAST"); + IF NOT EQUAL(XG2,XG2) THEN + COMMENT ("DON'T OPTIMIZE XG2"); + END IF; + EXCEPTION + WHEN CONSTRAINT_ERROR => + NULL; + WHEN OTHERS => + FAILED ("UNEXPECTED EXCEPTION (G)"); + END; + END GEN; + + PROCEDURE PROC IS NEW GEN(DG1, DG2); + +BEGIN + TEST ("C85005G", "CHECK THAT ANY SUBTYPE CONSTRAINT IMPOSED BY " & + "THE TYPE MARK USED IN THE RENAMING " & + "DECLARATION IS IGNORED, AND THE SUBTYPE " & + "CONSTRAINT ASSOCIATED WITH THE RENAMED " & + "VARIABLE IS USED INSTEAD"); + + IF XI /= INTEGER'LAST THEN + FAILED("INCORRECT VALUE OF RENAMING VARIABLE - 1"); + END IF; + + XI := IDENT_INT(INTEGER'FIRST); + + IF XI /= INTEGER'FIRST THEN + FAILED("INCORRECT VALUE OF RENAMING VARIABLE - 2"); + END IF; + + IF XJ /= INT'LAST THEN + FAILED("INCORRECT VALUE OF RENAMING VARIABLE - 3"); + END IF; + + XJ := IDENT_INT(INT'FIRST); + + IF XJ /= INT'FIRST THEN + FAILED("INCORRECT VALUE OF RENAMING VARIABLE - 4"); + END IF; + + BEGIN + XJ := IDENT_INT(INTEGER'LAST); + FAILED ("NO EXCEPTION RAISED BY XJ := INTEGER'LAST"); + IF NOT EQUAL(XJ,XJ) THEN + COMMENT ("DON'T OPTIMIZE XJ"); + END IF; + EXCEPTION + WHEN CONSTRAINT_ERROR => + NULL; + WHEN OTHERS => + FAILED ("UNEXPECTED EXCEPTION - 1"); + END; + + PROC; + + RESULT; +EXCEPTION + WHEN OTHERS => + FAILED("UNEXPECTED EXCEPTION - 2"); + RESULT; +END C85005G; diff --git a/gcc/testsuite/ada/acats/tests/c8/c85006a.ada b/gcc/testsuite/ada/acats/tests/c8/c85006a.ada new file mode 100644 index 000000000..be04e4dbe --- /dev/null +++ b/gcc/testsuite/ada/acats/tests/c8/c85006a.ada @@ -0,0 +1,681 @@ +-- C85006A.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 A COMPONENT OR SLICE OF A VARIABLE CREATED BY AN +-- OBJECT DECLARATION CAN BE RENAMED AND HAS THE CORRECT VALUE, +-- AND THAT THE NEW NAME CAN BE USED IN AN ASSIGNMENT STATEMENT +-- AND PASSED ON AS AN ACTUAL SUBPROGRAM OR ENTRY 'IN OUT' OR 'OUT' +-- PARAMETER, AND AS AN ACTUAL GENERIC 'IN OUT' PARAMETER, +-- AND THAT WHEN THE VALUE OF THE RENAMED VARIABLE IS CHANGED, +-- THE NEW VALUE IS REFLECTED BY THE VALUE OF THE NEW NAME. + +-- HISTORY: +-- JET 03/22/88 CREATED ORIGINAL TEST. + +WITH REPORT; USE REPORT; +PROCEDURE C85006A IS + + TYPE ARRAY1 IS ARRAY (POSITIVE RANGE <>) OF INTEGER; + TYPE RECORD1 (D : INTEGER) IS + RECORD + FIELD1 : INTEGER := 1; + END RECORD; + TYPE POINTER1 IS ACCESS INTEGER; + + PACKAGE PACK1 IS + TYPE PRIVY IS PRIVATE; + ZERO : CONSTANT PRIVY; + ONE : CONSTANT PRIVY; + TWO : CONSTANT PRIVY; + THREE : CONSTANT PRIVY; + FOUR : CONSTANT PRIVY; + FIVE : CONSTANT PRIVY; + FUNCTION IDENT (I : PRIVY) RETURN PRIVY; + FUNCTION NEXT (I : PRIVY) RETURN PRIVY; + PRIVATE + TYPE PRIVY IS RANGE 0..127; + ZERO : CONSTANT PRIVY := 0; + ONE : CONSTANT PRIVY := 1; + TWO : CONSTANT PRIVY := 2; + THREE : CONSTANT PRIVY := 3; + FOUR : CONSTANT PRIVY := 4; + FIVE : CONSTANT PRIVY := 5; + END PACK1; + + TASK TYPE TASK1 IS + ENTRY ASSIGN (J : IN INTEGER); + ENTRY VALU (J : OUT INTEGER); + ENTRY NEXT; + ENTRY STOP; + END TASK1; + + TYPE ARR_INT IS ARRAY(POSITIVE RANGE <>) OF INTEGER; + TYPE ARR_ARR IS ARRAY(POSITIVE RANGE <>) OF ARRAY1(1..3); + TYPE ARR_REC IS ARRAY(POSITIVE RANGE <>) OF RECORD1(1); + TYPE ARR_PTR IS ARRAY(POSITIVE RANGE <>) OF POINTER1; + TYPE ARR_PVT IS ARRAY(POSITIVE RANGE <>) OF PACK1.PRIVY; + TYPE ARR_TSK IS ARRAY(POSITIVE RANGE <>) OF TASK1; + + TASK TYPE TASK2 IS + ENTRY ENTRY1 (TRI1 : OUT INTEGER; TRA1 : OUT ARRAY1; + TRR1 : OUT RECORD1; TRP1 : IN OUT POINTER1; + TRV1 : IN OUT PACK1.PRIVY; TRT1 : IN OUT TASK1; + TAI1 : OUT ARR_INT; TAA1 : OUT ARR_ARR; + TAR1 : OUT ARR_REC; TAP1 : IN OUT ARR_PTR; + TAV1 : IN OUT ARR_PVT; TAT1 : IN OUT ARR_TSK); + END TASK2; + + TYPE REC_TYPE IS RECORD + RI1 : INTEGER := 0; + RA1 : ARRAY1(1..3) := (OTHERS => 0); + RR1 : RECORD1(1) := (D => 1, FIELD1 => 0); + RP1 : POINTER1 := NEW INTEGER'(0); + RV1 : PACK1.PRIVY := PACK1.ZERO; + RT1 : TASK1; + END RECORD; + + REC : REC_TYPE; + + AI1 : ARR_INT(1..8) := (OTHERS => 0); + AA1 : ARR_ARR(1..8) := (OTHERS => (OTHERS => 0)); + AR1 : ARR_REC(1..8) := (OTHERS => (D => 1, FIELD1 => 0)); + AP1 : ARR_PTR(1..8) := (OTHERS => NEW INTEGER'(0)); + AV1 : ARR_PVT(1..8) := (OTHERS => PACK1.ZERO); + AT1 : ARR_TSK(1..8); + + XRI1 : INTEGER RENAMES REC.RI1; + XRA1 : ARRAY1 RENAMES REC.RA1; + XRR1 : RECORD1 RENAMES REC.RR1; + XRP1 : POINTER1 RENAMES REC.RP1; + XRV1 : PACK1.PRIVY RENAMES REC.RV1; + XRT1 : TASK1 RENAMES REC.RT1; + XAI1 : ARR_INT RENAMES AI1(1..3); + XAA1 : ARR_ARR RENAMES AA1(2..4); + XAR1 : ARR_REC RENAMES AR1(3..5); + XAP1 : ARR_PTR RENAMES AP1(4..6); + XAV1 : ARR_PVT RENAMES AV1(5..7); + XAT1 : ARR_TSK RENAMES AT1(6..8); + + I : INTEGER; + CHK_TASK : TASK2; + + GENERIC + GRI1 : IN OUT INTEGER; + GRA1 : IN OUT ARRAY1; + GRR1 : IN OUT RECORD1; + GRP1 : IN OUT POINTER1; + GRV1 : IN OUT PACK1.PRIVY; + GRT1 : IN OUT TASK1; + GAI1 : IN OUT ARR_INT; + GAA1 : IN OUT ARR_ARR; + GAR1 : IN OUT ARR_REC; + GAP1 : IN OUT ARR_PTR; + GAV1 : IN OUT ARR_PVT; + GAT1 : IN OUT ARR_TSK; + PACKAGE GENERIC1 IS + END GENERIC1; + + FUNCTION IDENT (P : POINTER1) RETURN POINTER1 IS + BEGIN + IF EQUAL (3,3) THEN + RETURN P; + ELSE + RETURN NULL; + END IF; + END IDENT; + + PROCEDURE PROC1 (PRI1 : IN OUT INTEGER; PRA1 : IN OUT ARRAY1; + PRR1 : IN OUT RECORD1; PRP1 : OUT POINTER1; + PRV1 : OUT PACK1.PRIVY; PRT1 : IN OUT TASK1; + PAI1 : IN OUT ARR_INT; PAA1 : IN OUT ARR_ARR; + PAR1 : IN OUT ARR_REC; PAP1 : OUT ARR_PTR; + PAV1 : OUT ARR_PVT; PAT1 : IN OUT ARR_TSK) IS + + BEGIN + PRI1 := PRI1 + 1; + PRA1 := (PRA1(1)+1, PRA1(2)+1, PRA1(3)+1); + PRR1 := (D => 1, FIELD1 => PRR1.FIELD1 + 1); + PRP1 := NEW INTEGER'(REC.RP1.ALL + 1); + PRV1 := PACK1.NEXT(REC.RV1); + PRT1.NEXT; + PAI1 := (OTHERS => PAI1(PAI1'FIRST) + 1); + PAA1 := (OTHERS => (OTHERS => PAA1(PAA1'FIRST)(1) + 1)); + PAR1 := (OTHERS => (D => 1, + FIELD1 => (PAR1(PAR1'FIRST).FIELD1 + 1))); + PAP1 := (OTHERS => NEW INTEGER'(AP1(PAP1'FIRST).ALL + 1)); + FOR J IN PAV1'RANGE LOOP + PAV1(J) := PACK1.NEXT(AV1(J)); + END LOOP; + FOR J IN PAT1'RANGE LOOP + PAT1(J).NEXT; + END LOOP; + END PROC1; + + PACKAGE BODY PACK1 IS + FUNCTION IDENT (I : PRIVY) RETURN PRIVY IS + BEGIN + IF EQUAL(3,3) THEN + RETURN I; + ELSE + RETURN PRIVY'(0); + END IF; + END IDENT; + + FUNCTION NEXT (I : PRIVY) RETURN PRIVY IS + BEGIN + RETURN I+1; + END NEXT; + END PACK1; + + PACKAGE BODY GENERIC1 IS + BEGIN + GRI1 := GRI1 + 1; + GRA1 := (GRA1(1)+1, GRA1(2)+1, GRA1(3)+1); + GRR1 := (D => 1, FIELD1 => GRR1.FIELD1+1); + GRP1 := NEW INTEGER'(GRP1.ALL + 1); + GRV1 := PACK1.NEXT(GRV1); + GRT1.NEXT; + GAI1 := (OTHERS => GAI1(GAI1'FIRST) + 1); + GAA1 := (OTHERS => (OTHERS => GAA1(GAA1'FIRST)(1) + 1)); + GAR1 := (OTHERS => (D => 1, + FIELD1 => (GAR1(GAR1'FIRST).FIELD1 + 1))); + GAP1 := (OTHERS => NEW INTEGER'(GAP1(GAP1'FIRST).ALL + 1)); + FOR J IN GAV1'RANGE LOOP + GAV1(J) := PACK1.NEXT(GAV1(J)); + END LOOP; + FOR J IN GAT1'RANGE LOOP + GAT1(J).NEXT; + END LOOP; + END GENERIC1; + + TASK BODY TASK1 IS + TASK_VALUE : INTEGER := 0; + ACCEPTING_ENTRIES : BOOLEAN := TRUE; + BEGIN + WHILE ACCEPTING_ENTRIES LOOP + SELECT + ACCEPT ASSIGN (J : IN INTEGER) DO + TASK_VALUE := J; + END ASSIGN; + OR + ACCEPT VALU (J : OUT INTEGER) DO + J := TASK_VALUE; + END VALU; + OR + ACCEPT NEXT DO + TASK_VALUE := TASK_VALUE + 1; + END NEXT; + OR + ACCEPT STOP DO + ACCEPTING_ENTRIES := FALSE; + END STOP; + END SELECT; + END LOOP; + END TASK1; + + TASK BODY TASK2 IS + BEGIN + ACCEPT ENTRY1 (TRI1 : OUT INTEGER; TRA1 : OUT ARRAY1; + TRR1 : OUT RECORD1; TRP1 : IN OUT POINTER1; + TRV1 : IN OUT PACK1.PRIVY; TRT1: IN OUT TASK1; + TAI1 : OUT ARR_INT; TAA1 : OUT ARR_ARR; + TAR1 : OUT ARR_REC; TAP1 : IN OUT ARR_PTR; + TAV1 : IN OUT ARR_PVT; TAT1 : IN OUT ARR_TSK) + DO + TRI1 := REC.RI1 + 1; + TRA1 := (REC.RA1(1)+1, REC.RA1(2)+1, REC.RA1(3)+1); + TRR1 := (D => 1, FIELD1 => REC.RR1.FIELD1 + 1); + TRP1 := NEW INTEGER'(TRP1.ALL + 1); + TRV1 := PACK1.NEXT(TRV1); + TRT1.NEXT; + TAI1 := (OTHERS => AI1(TAI1'FIRST) + 1); + TAA1 := (OTHERS => (OTHERS => AA1(TAA1'FIRST)(1) + 1)); + TAR1 := (OTHERS => (D => 1, + FIELD1 => (AR1(TAR1'FIRST).FIELD1 + 1))); + TAP1 := (OTHERS => NEW INTEGER'(TAP1(TAP1'FIRST).ALL+1)); + FOR J IN TAV1'RANGE LOOP + TAV1(J) := PACK1.NEXT(TAV1(J)); + END LOOP; + FOR J IN TAT1'RANGE LOOP + TAT1(J).NEXT; + END LOOP; + END ENTRY1; + END TASK2; + +BEGIN + TEST ("C85006A", "CHECK THAT A COMPONENT OR SLICE OF A VARIABLE " & + "CREATED BY AN OBJECT DECLARATION CAN BE " & + "RENAMED AND HAS THE CORRECT VALUE, AND THAT " & + "THE NEW NAME CAN BE USED IN AN ASSIGNMENT " & + "STATEMENT AND PASSED ON AS AN ACTUAL " & + "SUBPROGRAM OR ENTRY 'IN OUT' OR 'OUT' " & + "PARAMETER, AND AS AN ACTUAL GENERIC 'IN OUT' " & + "PARAMETER, AND THAT WHEN THE VALUE OF THE " & + "RENAMED VARIABLE IS CHANGED, THE NEW VALUE IS " & + "REFLECTED BY THE VALUE OF THE NEW NAME"); + + DECLARE + PACKAGE GENPACK1 IS NEW + GENERIC1 (XRI1, XRA1, XRR1, XRP1, XRV1, XRT1, + XAI1, XAA1, XAR1, XAP1, XAV1, XAT1); + BEGIN + NULL; + END; + + IF XRI1 /= IDENT_INT(1) THEN + FAILED ("INCORRECT VALUE OF XRI1 (1)"); + END IF; + + IF XRA1 /= (IDENT_INT(1),IDENT_INT(1),IDENT_INT(1)) THEN + FAILED ("INCORRECT VALUE OF XRA1 (1)"); + END IF; + + IF XRR1 /= (D => 1, FIELD1 => IDENT_INT(1)) THEN + FAILED ("INCORRECT VALUE OF XRR1 (1)"); + END IF; + + IF XRP1 /= IDENT(REC.RP1) OR XRP1.ALL /= IDENT_INT(1) THEN + FAILED ("INCORRECT VALUE OF XRP1 (1)"); + END IF; + + IF PACK1."/=" (XRV1, PACK1.IDENT(PACK1.ONE)) THEN + FAILED ("INCORRECT VALUE OF XRV1 (1)"); + END IF; + + XRT1.VALU(I); + IF I /= IDENT_INT(1) THEN + FAILED ("INCORRECT RETURN VALUE OF XRT1.VALU (1)"); + END IF; + + FOR J IN XAI1'RANGE LOOP + IF XAI1(J) /= IDENT_INT(1) THEN + FAILED ("INCORRECT VALUE OF XAI1(" & INTEGER'IMAGE(J) & + ") (1)"); + END IF; + END LOOP; + + FOR J IN XAA1'RANGE LOOP + IF XAA1(J) /= (IDENT_INT(1),IDENT_INT(1),IDENT_INT(1)) THEN + FAILED ("INCORRECT VALUE OF XAA1(" & INTEGER'IMAGE(J) & + ") (1)"); + END IF; + END LOOP; + + FOR J IN XAR1'RANGE LOOP + IF XAR1(J) /= (D => 1, FIELD1 => IDENT_INT(1)) THEN + FAILED ("INCORRECT VALUE OF XAR1(" & INTEGER'IMAGE(J) & + ") (1)"); + END IF; + END LOOP; + + FOR J IN XAP1'RANGE LOOP + IF XAP1(J) /= IDENT(AP1(J)) OR XAP1(J).ALL /= IDENT_INT(1) + THEN + FAILED ("INCORRECT VALUE OF XAP1(" & INTEGER'IMAGE(J) & + ") (1)"); + END IF; + END LOOP; + + FOR J IN XAV1'RANGE LOOP + IF PACK1."/=" (XAV1(J), PACK1.IDENT(PACK1.ONE)) THEN + FAILED ("INCORRECT VALUE OF XAV1(" & INTEGER'IMAGE(J) & + ") (1)"); + END IF; + END LOOP; + + FOR J IN XAT1'RANGE LOOP + XAT1(J).VALU(I); + IF I /= IDENT_INT(1) THEN + FAILED ("INCORRECT RETURN VALUE FROM XAT1(" & + INTEGER'IMAGE(J) & ").VALU (1)"); + END IF; + END LOOP; + + PROC1 (XRI1, XRA1, XRR1, XRP1, XRV1, XRT1, + XAI1, XAA1, XAR1, XAP1, XAV1, XAT1); + + IF XRI1 /= IDENT_INT(2) THEN + FAILED ("INCORRECT VALUE OF XRI1 (2)"); + END IF; + + IF XRA1 /= (IDENT_INT(2),IDENT_INT(2),IDENT_INT(2)) THEN + FAILED ("INCORRECT VALUE OF XRA1 (2)"); + END IF; + + IF XRR1 /= (D => 1, FIELD1 => IDENT_INT(2)) THEN + FAILED ("INCORRECT VALUE OF XRR1 (2)"); + END IF; + + IF XRP1 /= IDENT(REC.RP1) OR XRP1.ALL /= IDENT_INT(2) THEN + FAILED ("INCORRECT VALUE OF XRP1 (2)"); + END IF; + + IF PACK1."/=" (XRV1, PACK1.IDENT(PACK1.TWO)) THEN + FAILED ("INCORRECT VALUE OF XRV1 (2)"); + END IF; + + XRT1.VALU(I); + IF I /= IDENT_INT(2) THEN + FAILED ("INCORRECT RETURN VALUE FROM XRT1.VALU (2)"); + END IF; + + FOR J IN XAI1'RANGE LOOP + IF XAI1(J) /= IDENT_INT(2) THEN + FAILED ("INCORRECT VALUE OF XAI1(" & INTEGER'IMAGE(J) & + ") (2)"); + END IF; + END LOOP; + + FOR J IN XAA1'RANGE LOOP + IF XAA1(J) /= (IDENT_INT(2),IDENT_INT(2),IDENT_INT(2)) THEN + FAILED ("INCORRECT VALUE OF XAA1(" & INTEGER'IMAGE(J) & + ") (2)"); + END IF; + END LOOP; + + FOR J IN XAR1'RANGE LOOP + IF XAR1(J) /= (D => 1, FIELD1 => IDENT_INT(2)) THEN + FAILED ("INCORRECT VALUE OF XAR1(" & INTEGER'IMAGE(J) & + ") (2)"); + END IF; + END LOOP; + + FOR J IN XAP1'RANGE LOOP + IF XAP1(J) /= IDENT(AP1(J)) OR XAP1(J).ALL /= IDENT_INT(2) + THEN + FAILED ("INCORRECT VALUE OF XAP1(" & INTEGER'IMAGE(J) & + ") (2)"); + END IF; + END LOOP; + + FOR J IN XAV1'RANGE LOOP + IF PACK1."/=" (XAV1(J), PACK1.IDENT(PACK1.TWO)) THEN + FAILED ("INCORRECT VALUE OF XAV1(" & INTEGER'IMAGE(J) & + ") (2)"); + END IF; + END LOOP; + + FOR J IN XAT1'RANGE LOOP + XAT1(J).VALU(I); + IF I /= IDENT_INT(2) THEN + FAILED ("INCORRECT RETURN VALUE FROM XAT1(" & + INTEGER'IMAGE(J) & ").VALU (2)"); + END IF; + END LOOP; + + CHK_TASK.ENTRY1(XRI1, XRA1, XRR1, XRP1, XRV1, XRT1, + XAI1, XAA1, XAR1, XAP1, XAV1, XAT1); + + IF XRI1 /= IDENT_INT(3) THEN + FAILED ("INCORRECT VALUE OF XRI1 (3)"); + END IF; + + IF XRA1 /= (IDENT_INT(3),IDENT_INT(3),IDENT_INT(3)) THEN + FAILED ("INCORRECT VALUE OF XRA1 (3)"); + END IF; + + IF XRR1 /= (D => 1, FIELD1 => IDENT_INT(3)) THEN + FAILED ("INCORRECT VALUE OF XRR1 (3)"); + END IF; + + IF XRP1 /= IDENT(REC.RP1) OR XRP1.ALL /= IDENT_INT(3) THEN + FAILED ("INCORRECT VALUE OF XRP1 (3)"); + END IF; + + IF PACK1."/=" (XRV1, PACK1.IDENT(PACK1.THREE)) THEN + FAILED ("INCORRECT VALUE OF XRV1 (3)"); + END IF; + + XRT1.VALU(I); + IF I /= IDENT_INT(3) THEN + FAILED ("INCORRECT RETURN VALUE OF XRT1.VALU (3)"); + END IF; + + FOR J IN XAI1'RANGE LOOP + IF XAI1(J) /= IDENT_INT(3) THEN + FAILED ("INCORRECT VALUE OF XAI1(" & INTEGER'IMAGE(J) & + ") (3)"); + END IF; + END LOOP; + + FOR J IN XAA1'RANGE LOOP + IF XAA1(J) /= (IDENT_INT(3),IDENT_INT(3),IDENT_INT(3)) THEN + FAILED ("INCORRECT VALUE OF XAA1(" & INTEGER'IMAGE(J) & + ") (3)"); + END IF; + END LOOP; + + FOR J IN XAR1'RANGE LOOP + IF XAR1(J) /= (D => 1, FIELD1 => IDENT_INT(3)) THEN + FAILED ("INCORRECT VALUE OF XAR1(" & INTEGER'IMAGE(J) & + ") (3)"); + END IF; + END LOOP; + + FOR J IN XAP1'RANGE LOOP + IF XAP1(J) /= IDENT(AP1(J)) OR XAP1(J).ALL /= IDENT_INT(3) + THEN + FAILED ("INCORRECT VALUE OF XAP1(" & INTEGER'IMAGE(J) & + ") (3)"); + END IF; + END LOOP; + + FOR J IN XAV1'RANGE LOOP + IF PACK1."/=" (XAV1(J), PACK1.IDENT(PACK1.THREE)) THEN + FAILED ("INCORRECT VALUE OF XAV1(" & INTEGER'IMAGE(J) & + ") (3)"); + END IF; + END LOOP; + + FOR J IN XAT1'RANGE LOOP + XAT1(J).VALU(I); + IF I /= IDENT_INT(3) THEN + FAILED ("INCORRECT RETURN VALUE FROM XAT1(" & + INTEGER'IMAGE(J) & ").VALU (3)"); + END IF; + END LOOP; + + XRI1 := XRI1 + 1; + XRA1 := (XRA1(1)+1, XRA1(2)+1, XRA1(3)+1); + XRR1 := (D => 1, FIELD1 => XRR1.FIELD1 + 1); + XRP1 := NEW INTEGER'(XRP1.ALL + 1); + XRV1 := PACK1.NEXT(XRV1); + XRT1.NEXT; + XAI1 := (OTHERS => XAI1(XAI1'FIRST) + 1); + XAA1 := (OTHERS => (OTHERS => XAA1(XAA1'FIRST)(1) + 1)); + XAR1 := (OTHERS => (D => 1, + FIELD1 => (XAR1(XAR1'FIRST).FIELD1 + 1))); + XAP1 := (OTHERS => NEW INTEGER'(XAP1(XAP1'FIRST).ALL + 1)); + FOR J IN XAV1'RANGE LOOP + XAV1(J) := PACK1.NEXT(XAV1(J)); + END LOOP; + FOR J IN XAT1'RANGE LOOP + XAT1(J).NEXT; + END LOOP; + + IF XRI1 /= IDENT_INT(4) THEN + FAILED ("INCORRECT VALUE OF XRI1 (4)"); + END IF; + + IF XRA1 /= (IDENT_INT(4),IDENT_INT(4),IDENT_INT(4)) THEN + FAILED ("INCORRECT VALUE OF XRA1 (4)"); + END IF; + + IF XRR1 /= (D => 1, FIELD1 => IDENT_INT(4)) THEN + FAILED ("INCORRECT VALUE OF XRR1 (4)"); + END IF; + + IF XRP1 /= IDENT(REC.RP1) OR XRP1.ALL /= IDENT_INT(4) THEN + FAILED ("INCORRECT VALUE OF XRP1 (4)"); + END IF; + + IF PACK1."/=" (XRV1, PACK1.IDENT(PACK1.FOUR)) THEN + FAILED ("INCORRECT VALUE OF XRV1 (4)"); + END IF; + + XRT1.VALU(I); + IF I /= IDENT_INT(4) THEN + FAILED ("INCORRECT RETURN VALUE OF XRT1.VALU (4)"); + END IF; + + FOR J IN XAI1'RANGE LOOP + IF XAI1(J) /= IDENT_INT(4) THEN + FAILED ("INCORRECT VALUE OF XAI1(" & INTEGER'IMAGE(J) & + ") (4)"); + END IF; + END LOOP; + + FOR J IN XAA1'RANGE LOOP + IF XAA1(J) /= (IDENT_INT(4),IDENT_INT(4),IDENT_INT(4)) THEN + FAILED ("INCORRECT VALUE OF XAA1(" & INTEGER'IMAGE(J) & + ") (4)"); + END IF; + END LOOP; + + FOR J IN XAR1'RANGE LOOP + IF XAR1(J) /= (D => 1, FIELD1 => IDENT_INT(4)) THEN + FAILED ("INCORRECT VALUE OF XAR1(" & INTEGER'IMAGE(J) & + ") (4)"); + END IF; + END LOOP; + + FOR J IN XAP1'RANGE LOOP + IF XAP1(J) /= IDENT(AP1(J)) OR XAP1(J).ALL /= IDENT_INT(4) + THEN + FAILED ("INCORRECT VALUE OF XAP1(" & INTEGER'IMAGE(J) & + ") (4)"); + END IF; + END LOOP; + + FOR J IN XAV1'RANGE LOOP + IF PACK1."/=" (XAV1(J), PACK1.IDENT(PACK1.FOUR)) THEN + FAILED ("INCORRECT VALUE OF XAV1(" & INTEGER'IMAGE(J) & + ") (4)"); + END IF; + END LOOP; + + FOR J IN XAT1'RANGE LOOP + XAT1(J).VALU(I); + IF I /= IDENT_INT(4) THEN + FAILED ("INCORRECT RETURN VALUE FROM XAT1(" & + INTEGER'IMAGE(J) & ").VALU (4)"); + END IF; + END LOOP; + + REC.RI1 := REC.RI1 + 1; + REC.RA1 := (REC.RA1(1)+1, REC.RA1(2)+1, REC.RA1(3)+1); + REC.RR1 := (D => 1, FIELD1 => REC.RR1.FIELD1 + 1); + REC.RP1 := NEW INTEGER'(REC.RP1.ALL + 1); + REC.RV1 := PACK1.NEXT(REC.RV1); + REC.RT1.NEXT; + AI1 := (OTHERS => AI1(XAI1'FIRST) + 1); + AA1 := (OTHERS => (OTHERS => AA1(XAA1'FIRST)(1) + 1)); + AR1 := (OTHERS => (D => 1, + FIELD1 => (AR1(XAR1'FIRST).FIELD1 + 1))); + AP1 := (OTHERS => NEW INTEGER'(AP1(XAP1'FIRST).ALL + 1)); + FOR J IN XAV1'RANGE LOOP + AV1(J) := PACK1.NEXT(AV1(J)); + END LOOP; + FOR J IN XAT1'RANGE LOOP + AT1(J).NEXT; + END LOOP; + + IF XRI1 /= IDENT_INT(5) THEN + FAILED ("INCORRECT VALUE OF XRI1 (5)"); + END IF; + + IF XRA1 /= (IDENT_INT(5),IDENT_INT(5),IDENT_INT(5)) THEN + FAILED ("INCORRECT VALUE OF XRA1 (5)"); + END IF; + + IF XRR1 /= (D => 1, FIELD1 => IDENT_INT(5)) THEN + FAILED ("INCORRECT VALUE OF XRR1 (5)"); + END IF; + + IF XRP1 /= IDENT(REC.RP1) OR XRP1.ALL /= IDENT_INT(5) THEN + FAILED ("INCORRECT VALUE OF XRP1 (5)"); + END IF; + + IF PACK1."/=" (XRV1, PACK1.IDENT(PACK1.FIVE)) THEN + FAILED ("INCORRECT VALUE OF XRV1 (5)"); + END IF; + + XRT1.VALU(I); + IF I /= IDENT_INT(5) THEN + FAILED ("INCORRECT RETURN VALUE OF XRT1.VALU (5)"); + END IF; + + FOR J IN XAI1'RANGE LOOP + IF XAI1(J) /= IDENT_INT(5) THEN + FAILED ("INCORRECT VALUE OF XAI1(" & INTEGER'IMAGE(J) & + ") (5)"); + END IF; + END LOOP; + + FOR J IN XAA1'RANGE LOOP + IF XAA1(J) /= (IDENT_INT(5),IDENT_INT(5),IDENT_INT(5)) THEN + FAILED ("INCORRECT VALUE OF XAA1(" & INTEGER'IMAGE(J) & + ") (5)"); + END IF; + END LOOP; + + FOR J IN XAR1'RANGE LOOP + IF XAR1(J) /= (D => 1, FIELD1 => IDENT_INT(5)) THEN + FAILED ("INCORRECT VALUE OF XAR1(" & INTEGER'IMAGE(J) & + ") (5)"); + END IF; + END LOOP; + + FOR J IN XAP1'RANGE LOOP + IF XAP1(J) /= IDENT(AP1(J)) OR XAP1(J).ALL /= IDENT_INT(5) + THEN + FAILED ("INCORRECT VALUE OF XAP1(" & INTEGER'IMAGE(J) & + ") (5)"); + END IF; + END LOOP; + + FOR J IN XAV1'RANGE LOOP + IF PACK1."/=" (XAV1(J), PACK1.IDENT(PACK1.FIVE)) THEN + FAILED ("INCORRECT VALUE OF XAV1(" & INTEGER'IMAGE(J) & + ") (5)"); + END IF; + END LOOP; + + FOR J IN XAT1'RANGE LOOP + XAT1(J).VALU(I); + IF I /= IDENT_INT(5) THEN + FAILED ("INCORRECT RETURN VALUE FROM XAT1(" & + INTEGER'IMAGE(J) & ").VALU (5)"); + END IF; + END LOOP; + + REC.RT1.STOP; + + FOR I IN AT1'RANGE LOOP + AT1(I).STOP; + END LOOP; + + RESULT; +END C85006A; diff --git a/gcc/testsuite/ada/acats/tests/c8/c85006b.ada b/gcc/testsuite/ada/acats/tests/c8/c85006b.ada new file mode 100644 index 000000000..885d8393a --- /dev/null +++ b/gcc/testsuite/ada/acats/tests/c8/c85006b.ada @@ -0,0 +1,699 @@ +-- C85006B.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 A COMPONENT OR SLICE OF A VARIABLE CREATED BY A +-- SUBPROGRAM 'IN OUT' FORMAL PARAMETER CAN BE RENAMED AND HAS THE +-- CORRECT VALUE, AND THAT THE NEW NAME CAN BE USED IN AN ASSIGNMENT +-- STATEMENT AND PASSED ON AS AN ACTUAL SUBPROGRAM OR ENTRY 'IN OUT' +-- OR 'OUT' PARAMETER, AND AS AN ACTUAL GENERIC 'IN OUT' PARAMETER, +-- AND THAT WHEN THE VALUE OF THE RENAMED VARIABLE IS CHANGED, +-- THE NEW VALUE IS REFLECTED BY THE VALUE OF THE NEW NAME. + +-- HISTORY: +-- JET 03/22/88 CREATED ORIGINAL TEST. + +WITH REPORT; USE REPORT; +PROCEDURE C85006B IS + + TYPE ARRAY1 IS ARRAY (POSITIVE RANGE <>) OF INTEGER; + TYPE RECORD1 (D : INTEGER) IS + RECORD + FIELD1 : INTEGER := 1; + END RECORD; + TYPE POINTER1 IS ACCESS INTEGER; + + PACKAGE PACK1 IS + TYPE PRIVY IS PRIVATE; + ZERO : CONSTANT PRIVY; + ONE : CONSTANT PRIVY; + TWO : CONSTANT PRIVY; + THREE : CONSTANT PRIVY; + FOUR : CONSTANT PRIVY; + FIVE : CONSTANT PRIVY; + FUNCTION IDENT (I : PRIVY) RETURN PRIVY; + FUNCTION NEXT (I : PRIVY) RETURN PRIVY; + PRIVATE + TYPE PRIVY IS RANGE 0..127; + ZERO : CONSTANT PRIVY := 0; + ONE : CONSTANT PRIVY := 1; + TWO : CONSTANT PRIVY := 2; + THREE : CONSTANT PRIVY := 3; + FOUR : CONSTANT PRIVY := 4; + FIVE : CONSTANT PRIVY := 5; + END PACK1; + + TASK TYPE TASK1 IS + ENTRY ASSIGN (J : IN INTEGER); + ENTRY VALU (J : OUT INTEGER); + ENTRY NEXT; + ENTRY STOP; + END TASK1; + + TYPE ARR_INT IS ARRAY(POSITIVE RANGE <>) OF INTEGER; + TYPE ARR_ARR IS ARRAY(POSITIVE RANGE <>) OF ARRAY1(1..3); + TYPE ARR_REC IS ARRAY(POSITIVE RANGE <>) OF RECORD1(1); + TYPE ARR_PTR IS ARRAY(POSITIVE RANGE <>) OF POINTER1; + TYPE ARR_PVT IS ARRAY(POSITIVE RANGE <>) OF PACK1.PRIVY; + TYPE ARR_TSK IS ARRAY(POSITIVE RANGE <>) OF TASK1; + + TYPE REC_TYPE IS RECORD + RI1 : INTEGER := 0; + RA1 : ARRAY1(1..3) := (OTHERS => 0); + RR1 : RECORD1(1) := (D => 1, FIELD1 => 0); + RP1 : POINTER1 := NEW INTEGER'(0); + RV1 : PACK1.PRIVY := PACK1.ZERO; + RT1 : TASK1; + END RECORD; + + DREC : REC_TYPE; + + DAI1 : ARR_INT(1..8) := (OTHERS => 0); + DAA1 : ARR_ARR(1..8) := (OTHERS => (OTHERS => 0)); + DAR1 : ARR_REC(1..8) := (OTHERS => (D => 1, FIELD1 => 0)); + DAP1 : ARR_PTR(1..8) := (OTHERS => NEW INTEGER'(0)); + DAV1 : ARR_PVT(1..8) := (OTHERS => PACK1.ZERO); + DAT1 : ARR_TSK(1..8); + + GENERIC + GRI1 : IN OUT INTEGER; + GRA1 : IN OUT ARRAY1; + GRR1 : IN OUT RECORD1; + GRP1 : IN OUT POINTER1; + GRV1 : IN OUT PACK1.PRIVY; + GRT1 : IN OUT TASK1; + GAI1 : IN OUT ARR_INT; + GAA1 : IN OUT ARR_ARR; + GAR1 : IN OUT ARR_REC; + GAP1 : IN OUT ARR_PTR; + GAV1 : IN OUT ARR_PVT; + GAT1 : IN OUT ARR_TSK; + PACKAGE GENERIC1 IS + END GENERIC1; + + FUNCTION IDENT (P : POINTER1) RETURN POINTER1 IS + BEGIN + IF EQUAL (3,3) THEN + RETURN P; + ELSE + RETURN NULL; + END IF; + END IDENT; + + PACKAGE BODY PACK1 IS + FUNCTION IDENT (I : PRIVY) RETURN PRIVY IS + BEGIN + IF EQUAL(3,3) THEN + RETURN I; + ELSE + RETURN PRIVY'(0); + END IF; + END IDENT; + + FUNCTION NEXT (I : PRIVY) RETURN PRIVY IS + BEGIN + RETURN I+1; + END NEXT; + END PACK1; + + PACKAGE BODY GENERIC1 IS + BEGIN + GRI1 := GRI1 + 1; + GRA1 := (GRA1(1)+1, GRA1(2)+1, GRA1(3)+1); + GRR1 := (D => 1, FIELD1 => GRR1.FIELD1+1); + GRP1 := NEW INTEGER'(GRP1.ALL + 1); + GRV1 := PACK1.NEXT(GRV1); + GRT1.NEXT; + GAI1 := (OTHERS => GAI1(GAI1'FIRST) + 1); + GAA1 := (OTHERS => (OTHERS => GAA1(GAA1'FIRST)(1) + 1)); + GAR1 := (OTHERS => (D => 1, + FIELD1 => (GAR1(GAR1'FIRST).FIELD1 + 1))); + GAP1 := (OTHERS => NEW INTEGER'(GAP1(GAP1'FIRST).ALL + 1)); + FOR J IN GAV1'RANGE LOOP + GAV1(J) := PACK1.NEXT(GAV1(J)); + END LOOP; + FOR J IN GAT1'RANGE LOOP + GAT1(J).NEXT; + END LOOP; + END GENERIC1; + + TASK BODY TASK1 IS + TASK_VALUE : INTEGER := 0; + ACCEPTING_ENTRIES : BOOLEAN := TRUE; + BEGIN + WHILE ACCEPTING_ENTRIES LOOP + SELECT + ACCEPT ASSIGN (J : IN INTEGER) DO + TASK_VALUE := J; + END ASSIGN; + OR + ACCEPT VALU (J : OUT INTEGER) DO + J := TASK_VALUE; + END VALU; + OR + ACCEPT NEXT DO + TASK_VALUE := TASK_VALUE + 1; + END NEXT; + OR + ACCEPT STOP DO + ACCEPTING_ENTRIES := FALSE; + END STOP; + END SELECT; + END LOOP; + END TASK1; + + PROCEDURE PROC (REC : IN OUT REC_TYPE; + AI1 : IN OUT ARR_INT; AA1 : IN OUT ARR_ARR; + AR1 : IN OUT ARR_REC; AP1 : IN OUT ARR_PTR; + AV1 : IN OUT ARR_PVT; AT1 : IN OUT ARR_TSK) IS + + XRI1 : INTEGER RENAMES REC.RI1; + XRA1 : ARRAY1 RENAMES REC.RA1; + XRR1 : RECORD1 RENAMES REC.RR1; + XRP1 : POINTER1 RENAMES REC.RP1; + XRV1 : PACK1.PRIVY RENAMES REC.RV1; + XRT1 : TASK1 RENAMES REC.RT1; + XAI1 : ARR_INT RENAMES AI1(1..3); + XAA1 : ARR_ARR RENAMES AA1(2..4); + XAR1 : ARR_REC RENAMES AR1(3..5); + XAP1 : ARR_PTR RENAMES AP1(4..6); + XAV1 : ARR_PVT RENAMES AV1(5..7); + XAT1 : ARR_TSK RENAMES AT1(6..8); + + TASK TYPE TASK2 IS + ENTRY ENTRY1 (TRI1 : OUT INTEGER; TRA1 : OUT ARRAY1; + TRR1 : OUT RECORD1; TRP1 : IN OUT POINTER1; + TRV1 : IN OUT PACK1.PRIVY; + TRT1 : IN OUT TASK1; + TAI1 : OUT ARR_INT; TAA1 : OUT ARR_ARR; + TAR1 : OUT ARR_REC; TAP1 : IN OUT ARR_PTR; + TAV1 : IN OUT ARR_PVT; + TAT1 : IN OUT ARR_TSK); + END TASK2; + + I : INTEGER; + CHK_TASK : TASK2; + + TASK BODY TASK2 IS + BEGIN + ACCEPT ENTRY1 (TRI1 : OUT INTEGER; TRA1 : OUT ARRAY1; + TRR1 : OUT RECORD1; + TRP1 : IN OUT POINTER1; + TRV1 : IN OUT PACK1.PRIVY; + TRT1: IN OUT TASK1; + TAI1 : OUT ARR_INT; TAA1 : OUT ARR_ARR; + TAR1 : OUT ARR_REC; TAP1 : IN OUT ARR_PTR; + TAV1 : IN OUT ARR_PVT; + TAT1 : IN OUT ARR_TSK) + DO + TRI1 := REC.RI1 + 1; + TRA1 := (REC.RA1(1)+1, REC.RA1(2)+1, REC.RA1(3)+1); + TRR1 := (D => 1, FIELD1 => REC.RR1.FIELD1 + 1); + TRP1 := NEW INTEGER'(TRP1.ALL + 1); + TRV1 := PACK1.NEXT(TRV1); + TRT1.NEXT; + TAI1 := (OTHERS => AI1(TAI1'FIRST) + 1); + TAA1 := (OTHERS => (OTHERS => + AA1(TAA1'FIRST)(1) + 1)); + TAR1 := (OTHERS => (D => 1, + FIELD1 => (AR1(TAR1'FIRST).FIELD1 + 1))); + TAP1 := (OTHERS => + NEW INTEGER'(TAP1(TAP1'FIRST).ALL+1)); + FOR J IN TAV1'RANGE LOOP + TAV1(J) := PACK1.NEXT(TAV1(J)); + END LOOP; + FOR J IN TAT1'RANGE LOOP + TAT1(J).NEXT; + END LOOP; + END ENTRY1; + END TASK2; + + PROCEDURE PROC1 (PRI1 : IN OUT INTEGER; PRA1 : IN OUT ARRAY1; + PRR1 : IN OUT RECORD1; PRP1 : OUT POINTER1; + PRV1 : OUT PACK1.PRIVY; PRT1 : IN OUT TASK1; + PAI1 : IN OUT ARR_INT; PAA1 : IN OUT ARR_ARR; + PAR1 : IN OUT ARR_REC; PAP1 : OUT ARR_PTR; + PAV1 : OUT ARR_PVT; PAT1 : IN OUT ARR_TSK) IS + BEGIN + PRI1 := PRI1 + 1; + PRA1 := (PRA1(1)+1, PRA1(2)+1, PRA1(3)+1); + PRR1 := (D => 1, FIELD1 => PRR1.FIELD1 + 1); + PRP1 := NEW INTEGER'(REC.RP1.ALL + 1); + PRV1 := PACK1.NEXT(REC.RV1); + PRT1.NEXT; + PAI1 := (OTHERS => PAI1(PAI1'FIRST) + 1); + PAA1 := (OTHERS => (OTHERS => PAA1(PAA1'FIRST)(1) + 1)); + PAR1 := (OTHERS => (D => 1, FIELD1 => + (PAR1(PAR1'FIRST).FIELD1 + 1))); + PAP1 := (OTHERS => NEW INTEGER'(AP1(PAP1'FIRST).ALL+1)); + FOR J IN PAV1'RANGE LOOP + PAV1(J) := PACK1.NEXT(AV1(J)); + END LOOP; + FOR J IN PAT1'RANGE LOOP + PAT1(J).NEXT; + END LOOP; + END PROC1; + + PACKAGE GENPACK1 IS NEW + GENERIC1 (XRI1, XRA1, XRR1, XRP1, XRV1, XRT1, + XAI1, XAA1, XAR1, XAP1, XAV1, XAT1); + + BEGIN + IF XRI1 /= IDENT_INT(1) THEN + FAILED ("INCORRECT VALUE OF XRI1 (1)"); + END IF; + + IF XRA1 /= (IDENT_INT(1),IDENT_INT(1),IDENT_INT(1)) THEN + FAILED ("INCORRECT VALUE OF XRA1 (1)"); + END IF; + + IF XRR1 /= (D => 1, FIELD1 => IDENT_INT(1)) THEN + FAILED ("INCORRECT VALUE OF XRR1 (1)"); + END IF; + + IF XRP1 /= IDENT(REC.RP1) OR XRP1.ALL /= IDENT_INT(1) THEN + FAILED ("INCORRECT VALUE OF XRP1 (1)"); + END IF; + + IF PACK1."/=" (XRV1, PACK1.IDENT(PACK1.ONE)) THEN + FAILED ("INCORRECT VALUE OF XRV1 (1)"); + END IF; + + XRT1.VALU(I); + IF I /= IDENT_INT(1) THEN + FAILED ("INCORRECT RETURN VALUE OF XRT1.VALU (1)"); + END IF; + + FOR J IN XAI1'RANGE LOOP + IF XAI1(J) /= IDENT_INT(1) THEN + FAILED ("INCORRECT VALUE OF XAI1(" & + INTEGER'IMAGE(J) & ") (1)"); + END IF; + END LOOP; + + FOR J IN XAA1'RANGE LOOP + IF XAA1(J) /= (IDENT_INT(1),IDENT_INT(1),IDENT_INT(1)) + THEN + FAILED ("INCORRECT VALUE OF XAA1(" & + INTEGER'IMAGE(J) & ") (1)"); + END IF; + END LOOP; + + FOR J IN XAR1'RANGE LOOP + IF XAR1(J) /= (D => 1, FIELD1 => IDENT_INT(1)) THEN + FAILED ("INCORRECT VALUE OF XAR1(" & + INTEGER'IMAGE(J) & ") (1)"); + END IF; + END LOOP; + + FOR J IN XAP1'RANGE LOOP + IF XAP1(J) /= IDENT(AP1(J)) OR + XAP1(J).ALL /= IDENT_INT(1) + THEN + FAILED ("INCORRECT VALUE OF XAP1(" & + INTEGER'IMAGE(J) & ") (1)"); + END IF; + END LOOP; + + FOR J IN XAV1'RANGE LOOP + IF PACK1."/=" (XAV1(J), PACK1.IDENT(PACK1.ONE)) THEN + FAILED ("INCORRECT VALUE OF XAV1(" & + INTEGER'IMAGE(J) & ") (1)"); + END IF; + END LOOP; + + FOR J IN XAT1'RANGE LOOP + XAT1(J).VALU(I); + IF I /= IDENT_INT(1) THEN + FAILED ("INCORRECT RETURN VALUE FROM XAT1(" & + INTEGER'IMAGE(J) & ").VALU (1)"); + END IF; + END LOOP; + + PROC1 (XRI1, XRA1, XRR1, XRP1, XRV1, XRT1, + XAI1, XAA1, XAR1, XAP1, XAV1, XAT1); + + IF XRI1 /= IDENT_INT(2) THEN + FAILED ("INCORRECT VALUE OF XRI1 (2)"); + END IF; + + IF XRA1 /= (IDENT_INT(2),IDENT_INT(2),IDENT_INT(2)) THEN + FAILED ("INCORRECT VALUE OF XRA1 (2)"); + END IF; + + IF XRR1 /= (D => 1, FIELD1 => IDENT_INT(2)) THEN + FAILED ("INCORRECT VALUE OF XRR1 (2)"); + END IF; + + IF XRP1 /= IDENT(REC.RP1) OR XRP1.ALL /= IDENT_INT(2) THEN + FAILED ("INCORRECT VALUE OF XRP1 (2)"); + END IF; + + IF PACK1."/=" (XRV1, PACK1.IDENT(PACK1.TWO)) THEN + FAILED ("INCORRECT VALUE OF XRV1 (2)"); + END IF; + + XRT1.VALU(I); + IF I /= IDENT_INT(2) THEN + FAILED ("INCORRECT RETURN VALUE FROM XRT1.VALU (2)"); + END IF; + + FOR J IN XAI1'RANGE LOOP + IF XAI1(J) /= IDENT_INT(2) THEN + FAILED ("INCORRECT VALUE OF XAI1(" & + INTEGER'IMAGE(J) & ") (2)"); + END IF; + END LOOP; + + FOR J IN XAA1'RANGE LOOP + IF XAA1(J) /= (IDENT_INT(2),IDENT_INT(2),IDENT_INT(2)) + THEN + FAILED ("INCORRECT VALUE OF XAA1(" & + INTEGER'IMAGE(J) & ") (2)"); + END IF; + END LOOP; + + FOR J IN XAR1'RANGE LOOP + IF XAR1(J) /= (D => 1, FIELD1 => IDENT_INT(2)) THEN + FAILED ("INCORRECT VALUE OF XAR1(" & + INTEGER'IMAGE(J) & ") (2)"); + END IF; + END LOOP; + + FOR J IN XAP1'RANGE LOOP + IF XAP1(J) /= IDENT(AP1(J)) OR + XAP1(J).ALL /= IDENT_INT(2) THEN + FAILED ("INCORRECT VALUE OF XAP1(" & + INTEGER'IMAGE(J) & ") (2)"); + END IF; + END LOOP; + + FOR J IN XAV1'RANGE LOOP + IF PACK1."/=" (XAV1(J), PACK1.IDENT(PACK1.TWO)) THEN + FAILED ("INCORRECT VALUE OF XAV1(" & + INTEGER'IMAGE(J) & ") (2)"); + END IF; + END LOOP; + + FOR J IN XAT1'RANGE LOOP + XAT1(J).VALU(I); + IF I /= IDENT_INT(2) THEN + FAILED ("INCORRECT RETURN VALUE FROM XAT1(" & + INTEGER'IMAGE(J) & ").VALU (2)"); + END IF; + END LOOP; + + CHK_TASK.ENTRY1(XRI1, XRA1, XRR1, XRP1, XRV1, XRT1, + XAI1, XAA1, XAR1, XAP1, XAV1, XAT1); + + IF XRI1 /= IDENT_INT(3) THEN + FAILED ("INCORRECT VALUE OF XRI1 (3)"); + END IF; + + IF XRA1 /= (IDENT_INT(3),IDENT_INT(3),IDENT_INT(3)) THEN + FAILED ("INCORRECT VALUE OF XRA1 (3)"); + END IF; + + IF XRR1 /= (D => 1, FIELD1 => IDENT_INT(3)) THEN + FAILED ("INCORRECT VALUE OF XRR1 (3)"); + END IF; + + IF XRP1 /= IDENT(REC.RP1) OR XRP1.ALL /= IDENT_INT(3) THEN + FAILED ("INCORRECT VALUE OF XRP1 (3)"); + END IF; + + IF PACK1."/=" (XRV1, PACK1.IDENT(PACK1.THREE)) THEN + FAILED ("INCORRECT VALUE OF XRV1 (3)"); + END IF; + + XRT1.VALU(I); + IF I /= IDENT_INT(3) THEN + FAILED ("INCORRECT RETURN VALUE OF XRT1.VALU (3)"); + END IF; + + FOR J IN XAI1'RANGE LOOP + IF XAI1(J) /= IDENT_INT(3) THEN + FAILED ("INCORRECT VALUE OF XAI1(" & + INTEGER'IMAGE(J) & ") (3)"); + END IF; + END LOOP; + + FOR J IN XAA1'RANGE LOOP + IF XAA1(J) /= (IDENT_INT(3),IDENT_INT(3),IDENT_INT(3)) + THEN + FAILED ("INCORRECT VALUE OF XAA1(" & + INTEGER'IMAGE(J) & ") (3)"); + END IF; + END LOOP; + + FOR J IN XAR1'RANGE LOOP + IF XAR1(J) /= (D => 1, FIELD1 => IDENT_INT(3)) THEN + FAILED ("INCORRECT VALUE OF XAR1(" & + INTEGER'IMAGE(J) & ") (3)"); + END IF; + END LOOP; + + FOR J IN XAP1'RANGE LOOP + IF XAP1(J) /= IDENT(AP1(J)) OR + XAP1(J).ALL /= IDENT_INT(3) THEN + FAILED ("INCORRECT VALUE OF XAP1(" & + INTEGER'IMAGE(J) & ") (3)"); + END IF; + END LOOP; + + FOR J IN XAV1'RANGE LOOP + IF PACK1."/=" (XAV1(J), PACK1.IDENT(PACK1.THREE)) THEN + FAILED ("INCORRECT VALUE OF XAV1(" & + INTEGER'IMAGE(J) & ") (3)"); + END IF; + END LOOP; + + FOR J IN XAT1'RANGE LOOP + XAT1(J).VALU(I); + IF I /= IDENT_INT(3) THEN + FAILED ("INCORRECT RETURN VALUE FROM XAT1(" & + INTEGER'IMAGE(J) & ").VALU (3)"); + END IF; + END LOOP; + + XRI1 := XRI1 + 1; + XRA1 := (XRA1(1)+1, XRA1(2)+1, XRA1(3)+1); + XRR1 := (D => 1, FIELD1 => XRR1.FIELD1 + 1); + XRP1 := NEW INTEGER'(XRP1.ALL + 1); + XRV1 := PACK1.NEXT(XRV1); + XRT1.NEXT; + XAI1 := (OTHERS => XAI1(XAI1'FIRST) + 1); + XAA1 := (OTHERS => (OTHERS => XAA1(XAA1'FIRST)(1) + 1)); + XAR1 := (OTHERS => (D => 1, + FIELD1 => (XAR1(XAR1'FIRST).FIELD1 + 1))); + XAP1 := (OTHERS => NEW INTEGER'(XAP1(XAP1'FIRST).ALL + 1)); + FOR J IN XAV1'RANGE LOOP + XAV1(J) := PACK1.NEXT(XAV1(J)); + END LOOP; + FOR J IN XAT1'RANGE LOOP + XAT1(J).NEXT; + END LOOP; + + IF XRI1 /= IDENT_INT(4) THEN + FAILED ("INCORRECT VALUE OF XRI1 (4)"); + END IF; + + IF XRA1 /= (IDENT_INT(4),IDENT_INT(4),IDENT_INT(4)) THEN + FAILED ("INCORRECT VALUE OF XRA1 (4)"); + END IF; + + IF XRR1 /= (D => 1, FIELD1 => IDENT_INT(4)) THEN + FAILED ("INCORRECT VALUE OF XRR1 (4)"); + END IF; + + IF XRP1 /= IDENT(REC.RP1) OR XRP1.ALL /= IDENT_INT(4) THEN + FAILED ("INCORRECT VALUE OF XRP1 (4)"); + END IF; + + IF PACK1."/=" (XRV1, PACK1.IDENT(PACK1.FOUR)) THEN + FAILED ("INCORRECT VALUE OF XRV1 (4)"); + END IF; + + XRT1.VALU(I); + IF I /= IDENT_INT(4) THEN + FAILED ("INCORRECT RETURN VALUE OF XRT1.VALU (4)"); + END IF; + + FOR J IN XAI1'RANGE LOOP + IF XAI1(J) /= IDENT_INT(4) THEN + FAILED ("INCORRECT VALUE OF XAI1(" & + INTEGER'IMAGE(J) & ") (4)"); + END IF; + END LOOP; + + FOR J IN XAA1'RANGE LOOP + IF XAA1(J) /= (IDENT_INT(4),IDENT_INT(4),IDENT_INT(4)) + THEN + FAILED ("INCORRECT VALUE OF XAA1(" & + INTEGER'IMAGE(J) & ") (4)"); + END IF; + END LOOP; + + FOR J IN XAR1'RANGE LOOP + IF XAR1(J) /= (D => 1, FIELD1 => IDENT_INT(4)) THEN + FAILED ("INCORRECT VALUE OF XAR1(" & + INTEGER'IMAGE(J) & ") (4)"); + END IF; + END LOOP; + + FOR J IN XAP1'RANGE LOOP + IF XAP1(J) /= IDENT(AP1(J)) OR + XAP1(J).ALL /= IDENT_INT(4) THEN + FAILED ("INCORRECT VALUE OF XAP1(" & + INTEGER'IMAGE(J) & ") (4)"); + END IF; + END LOOP; + + FOR J IN XAV1'RANGE LOOP + IF PACK1."/=" (XAV1(J), PACK1.IDENT(PACK1.FOUR)) THEN + FAILED ("INCORRECT VALUE OF XAV1(" & + INTEGER'IMAGE(J) & ") (4)"); + END IF; + END LOOP; + + FOR J IN XAT1'RANGE LOOP + XAT1(J).VALU(I); + IF I /= IDENT_INT(4) THEN + FAILED ("INCORRECT RETURN VALUE FROM XAT1(" & + INTEGER'IMAGE(J) & ").VALU (4)"); + END IF; + END LOOP; + + REC.RI1 := REC.RI1 + 1; + REC.RA1 := (REC.RA1(1)+1, REC.RA1(2)+1, REC.RA1(3)+1); + REC.RR1 := (D => 1, FIELD1 => REC.RR1.FIELD1 + 1); + REC.RP1 := NEW INTEGER'(REC.RP1.ALL + 1); + REC.RV1 := PACK1.NEXT(REC.RV1); + REC.RT1.NEXT; + AI1 := (OTHERS => AI1(XAI1'FIRST) + 1); + AA1 := (OTHERS => (OTHERS => AA1(XAA1'FIRST)(1) + 1)); + AR1 := (OTHERS => (D => 1, + FIELD1 => (AR1(XAR1'FIRST).FIELD1 + 1))); + AP1 := (OTHERS => NEW INTEGER'(AP1(XAP1'FIRST).ALL + 1)); + FOR J IN XAV1'RANGE LOOP + AV1(J) := PACK1.NEXT(AV1(J)); + END LOOP; + FOR J IN XAT1'RANGE LOOP + AT1(J).NEXT; + END LOOP; + + IF XRI1 /= IDENT_INT(5) THEN + FAILED ("INCORRECT VALUE OF XRI1 (5)"); + END IF; + + IF XRA1 /= (IDENT_INT(5),IDENT_INT(5),IDENT_INT(5)) THEN + FAILED ("INCORRECT VALUE OF XRA1 (5)"); + END IF; + + IF XRR1 /= (D => 1, FIELD1 => IDENT_INT(5)) THEN + FAILED ("INCORRECT VALUE OF XRR1 (5)"); + END IF; + + IF XRP1 /= IDENT(REC.RP1) OR XRP1.ALL /= IDENT_INT(5) THEN + FAILED ("INCORRECT VALUE OF XRP1 (5)"); + END IF; + + IF PACK1."/=" (XRV1, PACK1.IDENT(PACK1.FIVE)) THEN + FAILED ("INCORRECT VALUE OF XRV1 (5)"); + END IF; + + XRT1.VALU(I); + IF I /= IDENT_INT(5) THEN + FAILED ("INCORRECT RETURN VALUE OF XRT1.VALU (5)"); + END IF; + + FOR J IN XAI1'RANGE LOOP + IF XAI1(J) /= IDENT_INT(5) THEN + FAILED ("INCORRECT VALUE OF XAI1(" & + INTEGER'IMAGE(J) & ") (5)"); + END IF; + END LOOP; + + FOR J IN XAA1'RANGE LOOP + IF XAA1(J) /= (IDENT_INT(5),IDENT_INT(5),IDENT_INT(5)) + THEN + FAILED ("INCORRECT VALUE OF XAA1(" & + INTEGER'IMAGE(J) & ") (5)"); + END IF; + END LOOP; + + FOR J IN XAR1'RANGE LOOP + IF XAR1(J) /= (D => 1, FIELD1 => IDENT_INT(5)) THEN + FAILED ("INCORRECT VALUE OF XAR1(" & + INTEGER'IMAGE(J) & ") (5)"); + END IF; + END LOOP; + + FOR J IN XAP1'RANGE LOOP + IF XAP1(J) /= IDENT(AP1(J)) OR + XAP1(J).ALL /= IDENT_INT(5) THEN + FAILED ("INCORRECT VALUE OF XAP1(" & + INTEGER'IMAGE(J) & ") (5)"); + END IF; + END LOOP; + + FOR J IN XAV1'RANGE LOOP + IF PACK1."/=" (XAV1(J), PACK1.IDENT(PACK1.FIVE)) THEN + FAILED ("INCORRECT VALUE OF XAV1(" & + INTEGER'IMAGE(J) & ") (5)"); + END IF; + END LOOP; + + FOR J IN XAT1'RANGE LOOP + XAT1(J).VALU(I); + IF I /= IDENT_INT(5) THEN + FAILED ("INCORRECT RETURN VALUE FROM XAT1(" & + INTEGER'IMAGE(J) & ").VALU (5)"); + END IF; + END LOOP; + + END PROC; + +BEGIN + TEST ("C85006B", "CHECK THAT A COMPONENT OR SLICE OF A VARIABLE " & + "CREATED BY A SUBPROGRAM 'IN OUT' FORMAL " & + "PARAMETER CAN BE RENAMED AND HAS THE CORRECT " & + "VALUE, AND THAT THE NEW NAME CAN BE USED IN " & + "AN ASSIGNMENT STATEMENT AND PASSED ON AS AN " & + "ACTUAL SUBPROGRAM OR ENTRY 'IN OUT' OR 'OUT' " & + "PARAMETER, AND AS AN ACTUAL GENERIC 'IN OUT' " & + "PARAMETER, AND THAT WHEN THE VALUE OF THE " & + "RENAMED VARIABLE IS CHANGED, THE NEW VALUE IS " & + "REFLECTED BY THE VALUE OF THE NEW NAME"); + + PROC (DREC, DAI1, DAA1, DAR1, DAP1, DAV1, DAT1); + + DREC.RT1.STOP; + + FOR I IN DAT1'RANGE LOOP + DAT1(I).STOP; + END LOOP; + + RESULT; +END C85006B; diff --git a/gcc/testsuite/ada/acats/tests/c8/c85006c.ada b/gcc/testsuite/ada/acats/tests/c8/c85006c.ada new file mode 100644 index 000000000..74a7dbfb5 --- /dev/null +++ b/gcc/testsuite/ada/acats/tests/c8/c85006c.ada @@ -0,0 +1,778 @@ +-- C85006C.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 A COMPONENT OR SLICE OF A VARIABLE CREATED BY AN ENTRY +-- 'IN OUT' FORMAL PARAMETER CAN BE RENAMED AND HAS THE CORRECT +-- VALUE, AND THAT THE NEW NAME CAN BE USED IN AN ASSIGNMENT +-- STATEMENT AND PASSED ON AS AN ACTUAL SUBPROGRAM OR ENTRY +-- 'IN OUT' OR 'OUT' PARAMETER, AND AS AN ACTUAL GENERIC 'IN OUT' +-- PARAMETER, AND THAT WHEN THE VALUE OF THE RENAMED VARIABLE IS +-- CHANGED, THE NEW VALUE IS REFLECTED BY THE VALUE OF THE NEW NAME. + +-- HISTORY: +-- JET 03/22/88 CREATED ORIGINAL TEST. + +WITH REPORT; USE REPORT; +PROCEDURE C85006C IS + + TYPE ARRAY1 IS ARRAY (POSITIVE RANGE <>) OF INTEGER; + TYPE RECORD1 (D : INTEGER) IS + RECORD + FIELD1 : INTEGER := 1; + END RECORD; + TYPE POINTER1 IS ACCESS INTEGER; + + PACKAGE PACK1 IS + TYPE PRIVY IS PRIVATE; + ZERO : CONSTANT PRIVY; + ONE : CONSTANT PRIVY; + TWO : CONSTANT PRIVY; + THREE : CONSTANT PRIVY; + FOUR : CONSTANT PRIVY; + FIVE : CONSTANT PRIVY; + FUNCTION IDENT (I : PRIVY) RETURN PRIVY; + FUNCTION NEXT (I : PRIVY) RETURN PRIVY; + PRIVATE + TYPE PRIVY IS RANGE 0..127; + ZERO : CONSTANT PRIVY := 0; + ONE : CONSTANT PRIVY := 1; + TWO : CONSTANT PRIVY := 2; + THREE : CONSTANT PRIVY := 3; + FOUR : CONSTANT PRIVY := 4; + FIVE : CONSTANT PRIVY := 5; + END PACK1; + + TASK TYPE TASK1 IS + ENTRY ASSIGN (J : IN INTEGER); + ENTRY VALU (J : OUT INTEGER); + ENTRY NEXT; + ENTRY STOP; + END TASK1; + + TYPE ARR_INT IS ARRAY(POSITIVE RANGE <>) OF INTEGER; + TYPE ARR_ARR IS ARRAY(POSITIVE RANGE <>) OF ARRAY1(1..3); + TYPE ARR_REC IS ARRAY(POSITIVE RANGE <>) OF RECORD1(1); + TYPE ARR_PTR IS ARRAY(POSITIVE RANGE <>) OF POINTER1; + TYPE ARR_PVT IS ARRAY(POSITIVE RANGE <>) OF PACK1.PRIVY; + TYPE ARR_TSK IS ARRAY(POSITIVE RANGE <>) OF TASK1; + + TYPE REC_TYPE IS RECORD + RI1 : INTEGER := 0; + RA1 : ARRAY1(1..3) := (OTHERS => 0); + RR1 : RECORD1(1) := (D => 1, FIELD1 => 0); + RP1 : POINTER1 := NEW INTEGER'(0); + RV1 : PACK1.PRIVY := PACK1.ZERO; + RT1 : TASK1; + END RECORD; + + DREC : REC_TYPE; + + DAI1 : ARR_INT(1..8) := (OTHERS => 0); + DAA1 : ARR_ARR(1..8) := (OTHERS => (OTHERS => 0)); + DAR1 : ARR_REC(1..8) := (OTHERS => (D => 1, FIELD1 => 0)); + DAP1 : ARR_PTR(1..8) := (OTHERS => NEW INTEGER'(0)); + DAV1 : ARR_PVT(1..8) := (OTHERS => PACK1.ZERO); + DAT1 : ARR_TSK(1..8); + + I : INTEGER; + + GENERIC + GRI1 : IN OUT INTEGER; + GRA1 : IN OUT ARRAY1; + GRR1 : IN OUT RECORD1; + GRP1 : IN OUT POINTER1; + GRV1 : IN OUT PACK1.PRIVY; + GRT1 : IN OUT TASK1; + GAI1 : IN OUT ARR_INT; + GAA1 : IN OUT ARR_ARR; + GAR1 : IN OUT ARR_REC; + GAP1 : IN OUT ARR_PTR; + GAV1 : IN OUT ARR_PVT; + GAT1 : IN OUT ARR_TSK; + PACKAGE GENERIC1 IS + END GENERIC1; + + FUNCTION IDENT (P : POINTER1) RETURN POINTER1 IS + BEGIN + IF EQUAL (3,3) THEN + RETURN P; + ELSE + RETURN NULL; + END IF; + END IDENT; + + PACKAGE BODY PACK1 IS + FUNCTION IDENT (I : PRIVY) RETURN PRIVY IS + BEGIN + IF EQUAL(3,3) THEN + RETURN I; + ELSE + RETURN PRIVY'(0); + END IF; + END IDENT; + + FUNCTION NEXT (I : PRIVY) RETURN PRIVY IS + BEGIN + RETURN I+1; + END NEXT; + END PACK1; + + PACKAGE BODY GENERIC1 IS + BEGIN + GRI1 := GRI1 + 1; + GRA1 := (GRA1(1)+1, GRA1(2)+1, GRA1(3)+1); + GRR1 := (D => 1, FIELD1 => GRR1.FIELD1+1); + GRP1 := NEW INTEGER'(GRP1.ALL + 1); + GRV1 := PACK1.NEXT(GRV1); + GRT1.NEXT; + GAI1 := (OTHERS => GAI1(GAI1'FIRST) + 1); + GAA1 := (OTHERS => (OTHERS => GAA1(GAA1'FIRST)(1) + 1)); + GAR1 := (OTHERS => (D => 1, + FIELD1 => (GAR1(GAR1'FIRST).FIELD1 + 1))); + GAP1 := (OTHERS => NEW INTEGER'(GAP1(GAP1'FIRST).ALL + 1)); + FOR J IN GAV1'RANGE LOOP + GAV1(J) := PACK1.NEXT(GAV1(J)); + END LOOP; + FOR J IN GAT1'RANGE LOOP + GAT1(J).NEXT; + END LOOP; + END GENERIC1; + + TASK BODY TASK1 IS + TASK_VALUE : INTEGER := 0; + ACCEPTING_ENTRIES : BOOLEAN := TRUE; + BEGIN + WHILE ACCEPTING_ENTRIES LOOP + SELECT + ACCEPT ASSIGN (J : IN INTEGER) DO + TASK_VALUE := J; + END ASSIGN; + OR + ACCEPT VALU (J : OUT INTEGER) DO + J := TASK_VALUE; + END VALU; + OR + ACCEPT NEXT DO + TASK_VALUE := TASK_VALUE + 1; + END NEXT; + OR + ACCEPT STOP DO + ACCEPTING_ENTRIES := FALSE; + END STOP; + END SELECT; + END LOOP; + END TASK1; + +BEGIN + TEST ("C85006C", "CHECK THAT A COMPONENT OR SLICE OF A VARIABLE " & + "CREATED BY AN ENTRY 'IN OUT' FORMAL PARAMETER " & + "CAN BE RENAMED AND HAS THE CORRECT VALUE, AND " & + "THAT THE NEW NAME CAN BE USED IN AN ASSIGN" & + "MENT STATEMENT AND PASSED ON AS AN ACTUAL " & + "SUBPROGRAM OR ENTRY 'IN OUT' OR 'OUT' " & + "PARAMETER, AND AS AN ACTUAL GENERIC 'IN OUT' " & + "PARAMETER, AND THAT WHEN THE VALUE OF THE " & + "RENAMED VARIABLE IS CHANGED, THE NEW VALUE IS " & + "REFLECTED BY THE VALUE OF THE NEW NAME"); + + DECLARE + TASK MAIN_TASK IS + ENTRY START (REC : IN OUT REC_TYPE; + AI1 : IN OUT ARR_INT; AA1 : IN OUT ARR_ARR; + AR1 : IN OUT ARR_REC; AP1 : IN OUT ARR_PTR; + AV1 : IN OUT ARR_PVT; AT1 : IN OUT ARR_TSK); + END MAIN_TASK; + + TASK BODY MAIN_TASK IS + BEGIN + ACCEPT START (REC : IN OUT REC_TYPE; + AI1 : IN OUT ARR_INT; AA1 : IN OUT ARR_ARR; + AR1 : IN OUT ARR_REC; AP1 : IN OUT ARR_PTR; + AV1 : IN OUT ARR_PVT; AT1 : IN OUT ARR_TSK) + DO + DECLARE + XRI1 : INTEGER RENAMES REC.RI1; + XRA1 : ARRAY1 RENAMES REC.RA1; + XRR1 : RECORD1 RENAMES REC.RR1; + XRP1 : POINTER1 RENAMES REC.RP1; + XRV1 : PACK1.PRIVY RENAMES REC.RV1; + XRT1 : TASK1 RENAMES REC.RT1; + XAI1 : ARR_INT RENAMES AI1(1..3); + XAA1 : ARR_ARR RENAMES AA1(2..4); + XAR1 : ARR_REC RENAMES AR1(3..5); + XAP1 : ARR_PTR RENAMES AP1(4..6); + XAV1 : ARR_PVT RENAMES AV1(5..7); + XAT1 : ARR_TSK RENAMES AT1(6..8); + + TASK TYPE TASK2 IS + ENTRY ENTRY1 (TRI1 : OUT INTEGER; + TRA1 : OUT ARRAY1; + TRR1 : OUT RECORD1; + TRP1 : IN OUT POINTER1; + TRV1 : IN OUT PACK1.PRIVY; + TRT1 : IN OUT TASK1; + TAI1 : OUT ARR_INT; + TAA1 : OUT ARR_ARR; + TAR1 : OUT ARR_REC; + TAP1 : IN OUT ARR_PTR; + TAV1 : IN OUT ARR_PVT; + TAT1 : IN OUT ARR_TSK); + END TASK2; + + CHK_TASK : TASK2; + + TASK BODY TASK2 IS + BEGIN + ACCEPT ENTRY1 (TRI1 : OUT INTEGER; + TRA1 : OUT ARRAY1; + TRR1 : OUT RECORD1; + TRP1 : IN OUT POINTER1; + TRV1 : IN OUT PACK1.PRIVY; + TRT1: IN OUT TASK1; + TAI1 : OUT ARR_INT; + TAA1 : OUT ARR_ARR; + TAR1 : OUT ARR_REC; + TAP1 : IN OUT ARR_PTR; + TAV1 : IN OUT ARR_PVT; + TAT1 : IN OUT ARR_TSK) + DO + TRI1 := REC.RI1 + 1; + TRA1 := (REC.RA1(1)+1, REC.RA1(2)+1, + REC.RA1(3)+1); + TRR1 := (D => 1, FIELD1 => REC.RR1.FIELD1 + 1); + TRP1 := NEW INTEGER'(TRP1.ALL + 1); + TRV1 := PACK1.NEXT(TRV1); + TRT1.NEXT; + TAI1 := (OTHERS => AI1(TAI1'FIRST) + 1); + TAA1 := (OTHERS => (OTHERS => + AA1(TAA1'FIRST)(1) + 1)); + TAR1 := (OTHERS => (D => 1, FIELD1 => + (AR1(TAR1'FIRST).FIELD1 + 1))); + TAP1 := (OTHERS => + NEW INTEGER'(TAP1(TAP1'FIRST).ALL+1)); + FOR J IN TAV1'RANGE LOOP + TAV1(J) := PACK1.NEXT(TAV1(J)); + END LOOP; + FOR J IN TAT1'RANGE LOOP + TAT1(J).NEXT; + END LOOP; + END ENTRY1; + END TASK2; + + PROCEDURE PROC1 (PRI1 : IN OUT INTEGER; + PRA1 : IN OUT ARRAY1; + PRR1 : IN OUT RECORD1; + PRP1 : OUT POINTER1; + PRV1 : OUT PACK1.PRIVY; + PRT1 : IN OUT TASK1; + PAI1 : IN OUT ARR_INT; + PAA1 : IN OUT ARR_ARR; + PAR1 : IN OUT ARR_REC; + PAP1 : OUT ARR_PTR; + PAV1 : OUT ARR_PVT; + PAT1 : IN OUT ARR_TSK) IS + BEGIN + PRI1 := PRI1 + 1; + PRA1 := (PRA1(1)+1, PRA1(2)+1, PRA1(3)+1); + PRR1 := (D => 1, FIELD1 => PRR1.FIELD1 + 1); + PRP1 := NEW INTEGER'(REC.RP1.ALL + 1); + PRV1 := PACK1.NEXT(REC.RV1); + PRT1.NEXT; + PAI1 := (OTHERS => PAI1(PAI1'FIRST) + 1); + PAA1 := (OTHERS => (OTHERS => + PAA1(PAA1'FIRST)(1) + 1)); + PAR1 := (OTHERS => (D => 1, FIELD1 => + (PAR1(PAR1'FIRST).FIELD1+1))); + PAP1 := (OTHERS => + NEW INTEGER'(AP1(PAP1'FIRST).ALL + 1)); + FOR J IN PAV1'RANGE LOOP + PAV1(J) := PACK1.NEXT(AV1(J)); + END LOOP; + FOR J IN PAT1'RANGE LOOP + PAT1(J).NEXT; + END LOOP; + END PROC1; + + PACKAGE GENPACK2 IS NEW GENERIC1 + (XRI1, XRA1, XRR1, XRP1, XRV1, XRT1, + XAI1, XAA1, XAR1, XAP1, XAV1, XAT1); + + BEGIN + IF XRI1 /= IDENT_INT(1) THEN + FAILED ("INCORRECT VALUE OF XRI1 (1)"); + END IF; + + IF XRA1 /= (IDENT_INT(1),IDENT_INT(1), + IDENT_INT(1)) THEN + FAILED ("INCORRECT VALUE OF XRA1 (1)"); + END IF; + + IF XRR1 /= (D => 1, FIELD1 => IDENT_INT(1)) + THEN + FAILED ("INCORRECT VALUE OF XRR1 (1)"); + END IF; + + IF XRP1 /= IDENT(REC.RP1) OR + XRP1.ALL /= IDENT_INT(1) THEN + FAILED ("INCORRECT VALUE OF XRP1 (1)"); + END IF; + + IF PACK1."/=" (XRV1, PACK1.IDENT(PACK1.ONE)) + THEN + FAILED ("INCORRECT VALUE OF XRV1 (1)"); + END IF; + + XRT1.VALU(I); + IF I /= IDENT_INT(1) THEN + FAILED ("INCORRECT RETURN VALUE OF " & + "XRT1.VALU (1)"); + END IF; + + FOR J IN XAI1'RANGE LOOP + IF XAI1(J) /= IDENT_INT(1) THEN + FAILED ("INCORRECT VALUE OF XAI1(" & + INTEGER'IMAGE(J) & ") (1)"); + END IF; + END LOOP; + + FOR J IN XAA1'RANGE LOOP + IF XAA1(J) /= (IDENT_INT(1),IDENT_INT(1), + IDENT_INT(1)) THEN + FAILED ("INCORRECT VALUE OF XAA1(" & + INTEGER'IMAGE(J) & ") (1)"); + END IF; + END LOOP; + + FOR J IN XAR1'RANGE LOOP + IF XAR1(J) /= (D => 1, + FIELD1 => IDENT_INT(1)) THEN + FAILED ("INCORRECT VALUE OF XAR1(" & + INTEGER'IMAGE(J) & ") (1)"); + END IF; + END LOOP; + + FOR J IN XAP1'RANGE LOOP + IF XAP1(J) /= IDENT(AP1(J)) OR + XAP1(J).ALL /= IDENT_INT(1) THEN + FAILED ("INCORRECT VALUE OF XAP1(" & + INTEGER'IMAGE(J) & ") (1)"); + END IF; + END LOOP; + + FOR J IN XAV1'RANGE LOOP + IF PACK1."/=" (XAV1(J), + PACK1.IDENT(PACK1.ONE)) THEN + FAILED ("INCORRECT VALUE OF XAV1(" & + INTEGER'IMAGE(J) & ") (1)"); + END IF; + END LOOP; + + FOR J IN XAT1'RANGE LOOP + XAT1(J).VALU(I); + IF I /= IDENT_INT(1) THEN + FAILED ("INCORRECT RETURN VALUE " & + "FROM XAT1(" & INTEGER'IMAGE(J) & + ").VALU (1)"); + END IF; + END LOOP; + + PROC1 (XRI1, XRA1, XRR1, XRP1, XRV1, XRT1, + XAI1, XAA1, XAR1, XAP1, XAV1, XAT1); + + IF XRI1 /= IDENT_INT(2) THEN + FAILED ("INCORRECT VALUE OF XRI1 (2)"); + END IF; + + IF XRA1 /= (IDENT_INT(2),IDENT_INT(2), + IDENT_INT(2)) THEN + FAILED ("INCORRECT VALUE OF XRA1 (2)"); + END IF; + + IF XRR1 /= (D => 1, FIELD1 => IDENT_INT(2)) + THEN + FAILED ("INCORRECT VALUE OF XRR1 (2)"); + END IF; + + IF XRP1 /= IDENT(REC.RP1) OR + XRP1.ALL /= IDENT_INT(2) THEN + FAILED ("INCORRECT VALUE OF XRP1 (2)"); + END IF; + + IF PACK1."/=" (XRV1, PACK1.IDENT(PACK1.TWO)) + THEN + FAILED ("INCORRECT VALUE OF XRV1 (2)"); + END IF; + + XRT1.VALU(I); + IF I /= IDENT_INT(2) THEN + FAILED ("INCORRECT RETURN VALUE FROM " & + "XRT1.VALU (2)"); + END IF; + + FOR J IN XAI1'RANGE LOOP + IF XAI1(J) /= IDENT_INT(2) THEN + FAILED ("INCORRECT VALUE OF XAI1(" & + INTEGER'IMAGE(J) & ") (2)"); + END IF; + END LOOP; + + FOR J IN XAA1'RANGE LOOP + IF XAA1(J) /= (IDENT_INT(2),IDENT_INT(2), + IDENT_INT(2)) THEN + FAILED ("INCORRECT VALUE OF XAA1(" & + INTEGER'IMAGE(J) & ") (2)"); + END IF; + END LOOP; + + FOR J IN XAR1'RANGE LOOP + IF XAR1(J) /= (D => 1, + FIELD1 => IDENT_INT(2)) THEN + FAILED ("INCORRECT VALUE OF XAR1(" & + INTEGER'IMAGE(J) & ") (2)"); + END IF; + END LOOP; + + FOR J IN XAP1'RANGE LOOP + IF XAP1(J) /= IDENT(AP1(J)) OR + XAP1(J).ALL /= IDENT_INT(2) THEN + FAILED ("INCORRECT VALUE OF XAP1(" & + INTEGER'IMAGE(J) & ") (2)"); + END IF; + END LOOP; + + FOR J IN XAV1'RANGE LOOP + IF PACK1."/=" (XAV1(J), + PACK1.IDENT(PACK1.TWO)) THEN + FAILED ("INCORRECT VALUE OF XAV1(" & + INTEGER'IMAGE(J) & ") (2)"); + END IF; + END LOOP; + + FOR J IN XAT1'RANGE LOOP + XAT1(J).VALU(I); + IF I /= IDENT_INT(2) THEN + FAILED ("INCORRECT RETURN VALUE " & + "FROM XAT1(" & INTEGER'IMAGE(J) & + ").VALU (2)"); + END IF; + END LOOP; + + CHK_TASK.ENTRY1 + (XRI1, XRA1, XRR1, XRP1, XRV1, XRT1, + XAI1, XAA1, XAR1, XAP1, XAV1, XAT1); + + IF XRI1 /= IDENT_INT(3) THEN + FAILED ("INCORRECT VALUE OF XRI1 (3)"); + END IF; + + IF XRA1 /= (IDENT_INT(3),IDENT_INT(3), + IDENT_INT(3)) THEN + FAILED ("INCORRECT VALUE OF XRA1 (3)"); + END IF; + + IF XRR1 /= (D => 1, FIELD1 => IDENT_INT(3)) + THEN + FAILED ("INCORRECT VALUE OF XRR1 (3)"); + END IF; + + IF XRP1 /= IDENT(REC.RP1) OR + XRP1.ALL /= IDENT_INT(3) THEN + FAILED ("INCORRECT VALUE OF XRP1 (3)"); + END IF; + + IF PACK1."/=" (XRV1, PACK1.IDENT(PACK1.THREE)) + THEN + FAILED ("INCORRECT VALUE OF XRV1 (3)"); + END IF; + + XRT1.VALU(I); + IF I /= IDENT_INT(3) THEN + FAILED ("INCORRECT RETURN VALUE OF " & + "XRT1.VALU (3)"); + END IF; + + FOR J IN XAI1'RANGE LOOP + IF XAI1(J) /= IDENT_INT(3) THEN + FAILED ("INCORRECT VALUE OF XAI1(" & + INTEGER'IMAGE(J) & ") (3)"); + END IF; + END LOOP; + + FOR J IN XAA1'RANGE LOOP + IF XAA1(J) /= (IDENT_INT(3),IDENT_INT(3), + IDENT_INT(3)) + THEN + FAILED ("INCORRECT VALUE OF XAA1(" & + INTEGER'IMAGE(J) & ") (3)"); + END IF; + END LOOP; + + FOR J IN XAR1'RANGE LOOP + IF XAR1(J) /= (D => 1, + FIELD1 => IDENT_INT(3)) THEN + FAILED ("INCORRECT VALUE OF XAR1(" & + INTEGER'IMAGE(J) & ") (3)"); + END IF; + END LOOP; + + FOR J IN XAP1'RANGE LOOP + IF XAP1(J) /= IDENT(AP1(J)) OR + XAP1(J).ALL /= IDENT_INT(3) THEN + FAILED ("INCORRECT VALUE OF XAP1(" & + INTEGER'IMAGE(J) & ") (3)"); + END IF; + END LOOP; + + FOR J IN XAV1'RANGE LOOP + IF PACK1."/=" (XAV1(J), + PACK1.IDENT(PACK1.THREE)) THEN + FAILED ("INCORRECT VALUE OF XAV1(" & + INTEGER'IMAGE(J) & ") (3)"); + END IF; + END LOOP; + + FOR J IN XAT1'RANGE LOOP + XAT1(J).VALU(I); + IF I /= IDENT_INT(3) THEN + FAILED ("INCORRECT RETURN VALUE " & + "FROM XAT1(" & + INTEGER'IMAGE(J) & ").VALU (3)"); + END IF; + END LOOP; + + XRI1 := XRI1 + 1; + XRA1 := (XRA1(1)+1, XRA1(2)+1, XRA1(3)+1); + XRR1 := (D => 1, FIELD1 => XRR1.FIELD1 + 1); + XRP1 := NEW INTEGER'(XRP1.ALL + 1); + XRV1 := PACK1.NEXT(XRV1); + XRT1.NEXT; + XAI1 := (OTHERS => XAI1(XAI1'FIRST) + 1); + XAA1 := (OTHERS => + (OTHERS => XAA1(XAA1'FIRST)(1) + 1)); + XAR1 := (OTHERS => (D => 1, FIELD1 => + (XAR1(XAR1'FIRST).FIELD1 + 1))); + XAP1 := (OTHERS => + NEW INTEGER'(XAP1(XAP1'FIRST).ALL + 1)); + FOR J IN XAV1'RANGE LOOP + XAV1(J) := PACK1.NEXT(XAV1(J)); + END LOOP; + FOR J IN XAT1'RANGE LOOP + XAT1(J).NEXT; + END LOOP; + + IF XRI1 /= IDENT_INT(4) THEN + FAILED ("INCORRECT VALUE OF XRI1 (4)"); + END IF; + + IF XRA1 /= (IDENT_INT(4),IDENT_INT(4), + IDENT_INT(4)) THEN + FAILED ("INCORRECT VALUE OF XRA1 (4)"); + END IF; + + IF XRR1 /= (D => 1, FIELD1 => IDENT_INT(4)) + THEN + FAILED ("INCORRECT VALUE OF XRR1 (4)"); + END IF; + + IF XRP1 /= IDENT(REC.RP1) OR + XRP1.ALL /= IDENT_INT(4) THEN + FAILED ("INCORRECT VALUE OF XRP1 (4)"); + END IF; + + IF PACK1."/=" (XRV1, PACK1.IDENT(PACK1.FOUR)) + THEN + FAILED ("INCORRECT VALUE OF XRV1 (4)"); + END IF; + + XRT1.VALU(I); + IF I /= IDENT_INT(4) THEN + FAILED ("INCORRECT RETURN VALUE OF " & + "XRT1.VALU (4)"); + END IF; + + FOR J IN XAI1'RANGE LOOP + IF XAI1(J) /= IDENT_INT(4) THEN + FAILED ("INCORRECT VALUE OF XAI1(" & + INTEGER'IMAGE(J) & ") (4)"); + END IF; + END LOOP; + + FOR J IN XAA1'RANGE LOOP + IF XAA1(J) /= (IDENT_INT(4),IDENT_INT(4), + IDENT_INT(4)) THEN + FAILED ("INCORRECT VALUE OF XAA1(" & + INTEGER'IMAGE(J) & ") (4)"); + END IF; + END LOOP; + + FOR J IN XAR1'RANGE LOOP + IF XAR1(J) /= (D => 1, FIELD1 => + IDENT_INT(4)) THEN + FAILED ("INCORRECT VALUE OF XAR1(" & + INTEGER'IMAGE(J) & ") (4)"); + END IF; + END LOOP; + + FOR J IN XAP1'RANGE LOOP + IF XAP1(J) /= IDENT(AP1(J)) OR + XAP1(J).ALL /= IDENT_INT(4) THEN + FAILED ("INCORRECT VALUE OF XAP1(" & + INTEGER'IMAGE(J) & ") (4)"); + END IF; + END LOOP; + + FOR J IN XAV1'RANGE LOOP + IF PACK1."/=" (XAV1(J), + PACK1.IDENT(PACK1.FOUR)) THEN + FAILED ("INCORRECT VALUE OF XAV1(" & + INTEGER'IMAGE(J) & ") (4)"); + END IF; + END LOOP; + + FOR J IN XAT1'RANGE LOOP + XAT1(J).VALU(I); + IF I /= IDENT_INT(4) THEN + FAILED ("INCORRECT RETURN VALUE " & + "FROM XAT1(" & + INTEGER'IMAGE(J) & ").VALU (4)"); + END IF; + END LOOP; + + REC.RI1 := REC.RI1 + 1; + REC.RA1 := (REC.RA1(1)+1, REC.RA1(2)+1, + REC.RA1(3)+1); + REC.RR1 := (D => 1, FIELD1 => + REC.RR1.FIELD1 + 1); + REC.RP1 := NEW INTEGER'(REC.RP1.ALL + 1); + REC.RV1 := PACK1.NEXT(REC.RV1); + REC.RT1.NEXT; + AI1(XAI1'RANGE) := (OTHERS => + AI1(XAI1'FIRST) + 1); + AA1(XAA1'RANGE) := (OTHERS => + (OTHERS => AA1(XAA1'FIRST)(1) + 1)); + AR1(XAR1'RANGE) := (OTHERS => (D => 1, + FIELD1 => (AR1(XAR1'FIRST).FIELD1 + 1))); + AP1(XAP1'RANGE) := (OTHERS => + NEW INTEGER'(AP1(XAP1'FIRST).ALL + 1)); + FOR J IN XAV1'RANGE LOOP + AV1(J) := PACK1.NEXT(AV1(J)); + END LOOP; + FOR J IN XAT1'RANGE LOOP + AT1(J).NEXT; + END LOOP; + + IF XRI1 /= IDENT_INT(5) THEN + FAILED ("INCORRECT VALUE OF XRI1 (5)"); + END IF; + + IF XRA1 /= (IDENT_INT(5),IDENT_INT(5), + IDENT_INT(5)) THEN + FAILED ("INCORRECT VALUE OF XRA1 (5)"); + END IF; + + IF XRR1 /= (D => 1, FIELD1 => IDENT_INT(5)) + THEN + FAILED ("INCORRECT VALUE OF XRR1 (5)"); + END IF; + + IF XRP1 /= IDENT(REC.RP1) OR + XRP1.ALL /= IDENT_INT(5) THEN + FAILED ("INCORRECT VALUE OF XRP1 (5)"); + END IF; + + IF PACK1."/=" (XRV1, PACK1.IDENT(PACK1.FIVE)) + THEN + FAILED ("INCORRECT VALUE OF XRV1 (5)"); + END IF; + + XRT1.VALU(I); + IF I /= IDENT_INT(5) THEN + FAILED ("INCORRECT RETURN VALUE OF " & + "XRT1.VALU (5)"); + END IF; + + FOR J IN XAI1'RANGE LOOP + IF XAI1(J) /= IDENT_INT(5) THEN + FAILED ("INCORRECT VALUE OF XAI1(" & + INTEGER'IMAGE(J) & ") (5)"); + END IF; + END LOOP; + + FOR J IN XAA1'RANGE LOOP + IF XAA1(J) /= (IDENT_INT(5),IDENT_INT(5), + IDENT_INT(5)) THEN + FAILED ("INCORRECT VALUE OF XAA1(" & + INTEGER'IMAGE(J) & ") (5)"); + END IF; + END LOOP; + + FOR J IN XAR1'RANGE LOOP + IF XAR1(J) /= (D => 1, FIELD1 => + IDENT_INT(5)) THEN + FAILED ("INCORRECT VALUE OF XAR1(" & + INTEGER'IMAGE(J) & ") (5)"); + END IF; + END LOOP; + + FOR J IN XAP1'RANGE LOOP + IF XAP1(J) /= IDENT(AP1(J)) OR + XAP1(J).ALL /= IDENT_INT(5) THEN + FAILED ("INCORRECT VALUE OF XAP1(" & + INTEGER'IMAGE(J) & ") (5)"); + END IF; + END LOOP; + + FOR J IN XAV1'RANGE LOOP + IF PACK1."/=" (XAV1(J), + PACK1.IDENT(PACK1.FIVE)) THEN + FAILED ("INCORRECT VALUE OF XAV1(" & + INTEGER'IMAGE(J) & ") (5)"); + END IF; + END LOOP; + + FOR J IN XAT1'RANGE LOOP + XAT1(J).VALU(I); + IF I /= IDENT_INT(5) THEN + FAILED ("INCORRECT RETURN VALUE " & + "FROM XAT1(" & + INTEGER'IMAGE(J) & ").VALU (5)"); + END IF; + END LOOP; + END; + END START; + END MAIN_TASK; + + BEGIN + MAIN_TASK.START (DREC, DAI1, DAA1, DAR1, DAP1, DAV1, DAT1); + END; + + DREC.RT1.STOP; + + FOR I IN DAT1'RANGE LOOP + DAT1(I).STOP; + END LOOP; + + RESULT; +END C85006C; diff --git a/gcc/testsuite/ada/acats/tests/c8/c85006d.ada b/gcc/testsuite/ada/acats/tests/c8/c85006d.ada new file mode 100644 index 000000000..b93640214 --- /dev/null +++ b/gcc/testsuite/ada/acats/tests/c8/c85006d.ada @@ -0,0 +1,712 @@ +-- C85006D.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 A COMPONENT OR SLICE OF A VARIABLE CREATED BY A +-- GENERIC 'IN OUT' FORMAL PARAMETER CAN BE RENAMED AND HAS THE +-- CORRECT VALUE, AND THAT THE NEW NAME CAN BE USED IN AN ASSIGNMENT +-- STATEMENT AND PASSED ON AS AN ACTUAL SUBPROGRAM OR ENTRY 'IN OUT' +-- OR 'OUT' PARAMETER, AND AS AN ACTUAL GENERIC 'IN OUT' PARAMETER, +-- AND THAT WHEN THE VALUE OF THE RENAMED VARIABLE IS CHANGED, +-- THE NEW VALUE IS REFLECTED BY THE VALUE OF THE NEW NAME. + +-- HISTORY: +-- JET 03/22/88 CREATED ORIGINAL TEST. + +WITH REPORT; USE REPORT; +PROCEDURE C85006D IS + + TYPE ARRAY1 IS ARRAY (POSITIVE RANGE <>) OF INTEGER; + TYPE RECORD1 (D : INTEGER) IS + RECORD + FIELD1 : INTEGER := 1; + END RECORD; + TYPE POINTER1 IS ACCESS INTEGER; + + PACKAGE PACK1 IS + TYPE PRIVY IS PRIVATE; + ZERO : CONSTANT PRIVY; + ONE : CONSTANT PRIVY; + TWO : CONSTANT PRIVY; + THREE : CONSTANT PRIVY; + FOUR : CONSTANT PRIVY; + FIVE : CONSTANT PRIVY; + FUNCTION IDENT (I : PRIVY) RETURN PRIVY; + FUNCTION NEXT (I : PRIVY) RETURN PRIVY; + PRIVATE + TYPE PRIVY IS RANGE 0..127; + ZERO : CONSTANT PRIVY := 0; + ONE : CONSTANT PRIVY := 1; + TWO : CONSTANT PRIVY := 2; + THREE : CONSTANT PRIVY := 3; + FOUR : CONSTANT PRIVY := 4; + FIVE : CONSTANT PRIVY := 5; + END PACK1; + + TASK TYPE TASK1 IS + ENTRY ASSIGN (J : IN INTEGER); + ENTRY VALU (J : OUT INTEGER); + ENTRY NEXT; + ENTRY STOP; + END TASK1; + + TYPE ARR_INT IS ARRAY(POSITIVE RANGE <>) OF INTEGER; + TYPE ARR_ARR IS ARRAY(POSITIVE RANGE <>) OF ARRAY1(1..3); + TYPE ARR_REC IS ARRAY(POSITIVE RANGE <>) OF RECORD1(1); + TYPE ARR_PTR IS ARRAY(POSITIVE RANGE <>) OF POINTER1; + TYPE ARR_PVT IS ARRAY(POSITIVE RANGE <>) OF PACK1.PRIVY; + TYPE ARR_TSK IS ARRAY(POSITIVE RANGE <>) OF TASK1; + + TYPE REC_TYPE IS RECORD + RI1 : INTEGER := 0; + RA1 : ARRAY1(1..3) := (OTHERS => 0); + RR1 : RECORD1(1) := (D => 1, FIELD1 => 0); + RP1 : POINTER1 := NEW INTEGER'(0); + RV1 : PACK1.PRIVY := PACK1.ZERO; + RT1 : TASK1; + END RECORD; + + DREC : REC_TYPE; + + DAI1 : ARR_INT(1..8) := (OTHERS => 0); + DAA1 : ARR_ARR(1..8) := (OTHERS => (OTHERS => 0)); + DAR1 : ARR_REC(1..8) := (OTHERS => (D => 1, FIELD1 => 0)); + DAP1 : ARR_PTR(1..8) := (OTHERS => NEW INTEGER'(0)); + DAV1 : ARR_PVT(1..8) := (OTHERS => PACK1.ZERO); + DAT1 : ARR_TSK(1..8); + + GENERIC + REC : IN OUT REC_TYPE; + AI1 : IN OUT ARR_INT; + AA1 : IN OUT ARR_ARR; + AR1 : IN OUT ARR_REC; + AP1 : IN OUT ARR_PTR; + AV1 : IN OUT ARR_PVT; + AT1 : IN OUT ARR_TSK; + PACKAGE GENERIC1 IS + END GENERIC1; + + FUNCTION IDENT (P : POINTER1) RETURN POINTER1 IS + BEGIN + IF EQUAL (3,3) THEN + RETURN P; + ELSE + RETURN NULL; + END IF; + END IDENT; + + PACKAGE BODY PACK1 IS + FUNCTION IDENT (I : PRIVY) RETURN PRIVY IS + BEGIN + IF EQUAL(3,3) THEN + RETURN I; + ELSE + RETURN PRIVY'(0); + END IF; + END IDENT; + + FUNCTION NEXT (I : PRIVY) RETURN PRIVY IS + BEGIN + RETURN I+1; + END NEXT; + END PACK1; + + PACKAGE BODY GENERIC1 IS + XRI1 : INTEGER RENAMES REC.RI1; + XRA1 : ARRAY1 RENAMES REC.RA1; + XRR1 : RECORD1 RENAMES REC.RR1; + XRP1 : POINTER1 RENAMES REC.RP1; + XRV1 : PACK1.PRIVY RENAMES REC.RV1; + XRT1 : TASK1 RENAMES REC.RT1; + XAI1 : ARR_INT RENAMES AI1(1..3); + XAA1 : ARR_ARR RENAMES AA1(2..4); + XAR1 : ARR_REC RENAMES AR1(3..5); + XAP1 : ARR_PTR RENAMES AP1(4..6); + XAV1 : ARR_PVT RENAMES AV1(5..7); + XAT1 : ARR_TSK RENAMES AT1(6..8); + + TASK TYPE TASK2 IS + ENTRY ENTRY1 (TRI1 : OUT INTEGER; TRA1 : OUT ARRAY1; + TRR1 : OUT RECORD1; TRP1 : IN OUT POINTER1; + TRV1 : IN OUT PACK1.PRIVY; + TRT1 : IN OUT TASK1; + TAI1 : OUT ARR_INT; TAA1 : OUT ARR_ARR; + TAR1 : OUT ARR_REC; TAP1 : IN OUT ARR_PTR; + TAV1 : IN OUT ARR_PVT; + TAT1 : IN OUT ARR_TSK); + END TASK2; + + CHK_TASK : TASK2; + I : INTEGER; + + GENERIC + GRI1 : IN OUT INTEGER; + GRA1 : IN OUT ARRAY1; + GRR1 : IN OUT RECORD1; + GRP1 : IN OUT POINTER1; + GRV1 : IN OUT PACK1.PRIVY; + GRT1 : IN OUT TASK1; + GAI1 : IN OUT ARR_INT; + GAA1 : IN OUT ARR_ARR; + GAR1 : IN OUT ARR_REC; + GAP1 : IN OUT ARR_PTR; + GAV1 : IN OUT ARR_PVT; + GAT1 : IN OUT ARR_TSK; + PACKAGE GENERIC2 IS + END GENERIC2; + + PACKAGE BODY GENERIC2 IS + BEGIN + GRI1 := GRI1 + 1; + GRA1 := (GRA1(1)+1, GRA1(2)+1, GRA1(3)+1); + GRR1 := (D => 1, FIELD1 => GRR1.FIELD1+1); + GRP1 := NEW INTEGER'(GRP1.ALL + 1); + GRV1 := PACK1.NEXT(GRV1); + GRT1.NEXT; + GAI1 := (OTHERS => GAI1(GAI1'FIRST) + 1); + GAA1 := (OTHERS => (OTHERS => GAA1(GAA1'FIRST)(1) + 1)); + GAR1 := (OTHERS => (D => 1, + FIELD1 => (GAR1(GAR1'FIRST).FIELD1 + 1))); + GAP1 := (OTHERS => + NEW INTEGER'(GAP1(GAP1'FIRST).ALL + 1)); + FOR J IN GAV1'RANGE LOOP + GAV1(J) := PACK1.NEXT(GAV1(J)); + END LOOP; + FOR J IN GAT1'RANGE LOOP + GAT1(J).NEXT; + END LOOP; + END GENERIC2; + + PROCEDURE PROC1 (PRI1 : IN OUT INTEGER; PRA1 : IN OUT ARRAY1; + PRR1 : IN OUT RECORD1; PRP1 : OUT POINTER1; + PRV1 : OUT PACK1.PRIVY; PRT1 : IN OUT TASK1; + PAI1 : IN OUT ARR_INT; PAA1 : IN OUT ARR_ARR; + PAR1 : IN OUT ARR_REC; PAP1 : OUT ARR_PTR; + PAV1 : OUT ARR_PVT; PAT1 : IN OUT ARR_TSK) IS + BEGIN + PRI1 := PRI1 + 1; + PRA1 := (PRA1(1)+1, PRA1(2)+1, PRA1(3)+1); + PRR1 := (D => 1, FIELD1 => PRR1.FIELD1 + 1); + PRP1 := NEW INTEGER'(REC.RP1.ALL + 1); + PRV1 := PACK1.NEXT(REC.RV1); + PRT1.NEXT; + PAI1 := (OTHERS => PAI1(PAI1'FIRST) + 1); + PAA1 := (OTHERS => (OTHERS => PAA1(PAA1'FIRST)(1) + 1)); + PAR1 := (OTHERS => (D => 1, FIELD1 => + (PAR1(PAR1'FIRST).FIELD1 + 1))); + PAP1 := (OTHERS => + NEW INTEGER'(AP1(PAP1'FIRST).ALL + 1)); + FOR J IN PAV1'RANGE LOOP + PAV1(J) := PACK1.NEXT(AV1(J)); + END LOOP; + FOR J IN PAT1'RANGE LOOP + PAT1(J).NEXT; + END LOOP; + END PROC1; + + TASK BODY TASK2 IS + BEGIN + ACCEPT ENTRY1 (TRI1 : OUT INTEGER; TRA1 : OUT ARRAY1; + TRR1 : OUT RECORD1; + TRP1 : IN OUT POINTER1; + TRV1 : IN OUT PACK1.PRIVY; + TRT1: IN OUT TASK1; + TAI1 : OUT ARR_INT; TAA1 : OUT ARR_ARR; + TAR1 : OUT ARR_REC; TAP1 : IN OUT ARR_PTR; + TAV1 : IN OUT ARR_PVT; + TAT1 : IN OUT ARR_TSK) + DO + TRI1 := REC.RI1 + 1; + TRA1 := (REC.RA1(1)+1, REC.RA1(2)+1, REC.RA1(3)+1); + TRR1 := (D => 1, FIELD1 => REC.RR1.FIELD1 + 1); + TRP1 := NEW INTEGER'(TRP1.ALL + 1); + TRV1 := PACK1.NEXT(TRV1); + TRT1.NEXT; + TAI1 := (OTHERS => AI1(TAI1'FIRST) + 1); + TAA1 := (OTHERS => (OTHERS => + AA1(TAA1'FIRST)(1) + 1)); + TAR1 := (OTHERS => (D => 1, FIELD1 => + (AR1(TAR1'FIRST).FIELD1 + 1))); + TAP1 := (OTHERS => + NEW INTEGER'(TAP1(TAP1'FIRST).ALL + 1)); + FOR J IN TAV1'RANGE LOOP + TAV1(J) := PACK1.NEXT(TAV1(J)); + END LOOP; + FOR J IN TAT1'RANGE LOOP + TAT1(J).NEXT; + END LOOP; + END ENTRY1; + END TASK2; + + PACKAGE GENPACK2 IS NEW + GENERIC2 (XRI1, XRA1, XRR1, XRP1, XRV1, XRT1, + XAI1, XAA1, XAR1, XAP1, XAV1, XAT1); + + BEGIN + IF XRI1 /= IDENT_INT(1) THEN + FAILED ("INCORRECT VALUE OF XRI1 (1)"); + END IF; + + IF XRA1 /= (IDENT_INT(1),IDENT_INT(1),IDENT_INT(1)) THEN + FAILED ("INCORRECT VALUE OF XRA1 (1)"); + END IF; + + IF XRR1 /= (D => 1, FIELD1 => IDENT_INT(1)) THEN + FAILED ("INCORRECT VALUE OF XRR1 (1)"); + END IF; + + IF XRP1 /= IDENT(REC.RP1) OR XRP1.ALL /= IDENT_INT(1) THEN + FAILED ("INCORRECT VALUE OF XRP1 (1)"); + END IF; + + IF PACK1."/=" (XRV1, PACK1.IDENT(PACK1.ONE)) THEN + FAILED ("INCORRECT VALUE OF XRV1 (1)"); + END IF; + + XRT1.VALU(I); + IF I /= IDENT_INT(1) THEN + FAILED ("INCORRECT RETURN VALUE OF XRT1.VALU (1)"); + END IF; + + FOR J IN XAI1'RANGE LOOP + IF XAI1(J) /= IDENT_INT(1) THEN + FAILED ("INCORRECT VALUE OF XAI1(" & + INTEGER'IMAGE(J) & ") (1)"); + END IF; + END LOOP; + + FOR J IN XAA1'RANGE LOOP + IF XAA1(J) /= (IDENT_INT(1),IDENT_INT(1),IDENT_INT(1)) + THEN + FAILED ("INCORRECT VALUE OF XAA1(" & + INTEGER'IMAGE(J) & ") (1)"); + END IF; + END LOOP; + + FOR J IN XAR1'RANGE LOOP + IF XAR1(J) /= (D => 1, FIELD1 => IDENT_INT(1)) THEN + FAILED ("INCORRECT VALUE OF XAR1(" & + INTEGER'IMAGE(J) & ") (1)"); + END IF; + END LOOP; + + FOR J IN XAP1'RANGE LOOP + IF XAP1(J) /= IDENT(AP1(J)) OR + XAP1(J).ALL /= IDENT_INT(1) + THEN + FAILED ("INCORRECT VALUE OF XAP1(" & + INTEGER'IMAGE(J) & ") (1)"); + END IF; + END LOOP; + + FOR J IN XAV1'RANGE LOOP + IF PACK1."/=" (XAV1(J), PACK1.IDENT(PACK1.ONE)) THEN + FAILED ("INCORRECT VALUE OF XAV1(" & + INTEGER'IMAGE(J) & ") (1)"); + END IF; + END LOOP; + + FOR J IN XAT1'RANGE LOOP + XAT1(J).VALU(I); + IF I /= IDENT_INT(1) THEN + FAILED ("INCORRECT RETURN VALUE FROM XAT1(" & + INTEGER'IMAGE(J) & ").VALU (1)"); + END IF; + END LOOP; + + PROC1 (XRI1, XRA1, XRR1, XRP1, XRV1, XRT1, + XAI1, XAA1, XAR1, XAP1, XAV1, XAT1); + + IF XRI1 /= IDENT_INT(2) THEN + FAILED ("INCORRECT VALUE OF XRI1 (2)"); + END IF; + + IF XRA1 /= (IDENT_INT(2),IDENT_INT(2),IDENT_INT(2)) THEN + FAILED ("INCORRECT VALUE OF XRA1 (2)"); + END IF; + + IF XRR1 /= (D => 1, FIELD1 => IDENT_INT(2)) THEN + FAILED ("INCORRECT VALUE OF XRR1 (2)"); + END IF; + + IF XRP1 /= IDENT(REC.RP1) OR XRP1.ALL /= IDENT_INT(2) THEN + FAILED ("INCORRECT VALUE OF XRP1 (2)"); + END IF; + + IF PACK1."/=" (XRV1, PACK1.IDENT(PACK1.TWO)) THEN + FAILED ("INCORRECT VALUE OF XRV1 (2)"); + END IF; + + XRT1.VALU(I); + IF I /= IDENT_INT(2) THEN + FAILED ("INCORRECT RETURN VALUE FROM XRT1.VALU (2)"); + END IF; + + FOR J IN XAI1'RANGE LOOP + IF XAI1(J) /= IDENT_INT(2) THEN + FAILED ("INCORRECT VALUE OF XAI1(" & + INTEGER'IMAGE(J) & ") (2)"); + END IF; + END LOOP; + + FOR J IN XAA1'RANGE LOOP + IF XAA1(J) /= (IDENT_INT(2),IDENT_INT(2),IDENT_INT(2)) + THEN + FAILED ("INCORRECT VALUE OF XAA1(" & + INTEGER'IMAGE(J) & ") (2)"); + END IF; + END LOOP; + + FOR J IN XAR1'RANGE LOOP + IF XAR1(J) /= (D => 1, FIELD1 => IDENT_INT(2)) THEN + FAILED ("INCORRECT VALUE OF XAR1(" & + INTEGER'IMAGE(J) & ") (2)"); + END IF; + END LOOP; + + FOR J IN XAP1'RANGE LOOP + IF XAP1(J) /= IDENT(AP1(J)) OR + XAP1(J).ALL /= IDENT_INT(2) THEN + FAILED ("INCORRECT VALUE OF XAP1(" & + INTEGER'IMAGE(J) & ") (2)"); + END IF; + END LOOP; + + FOR J IN XAV1'RANGE LOOP + IF PACK1."/=" (XAV1(J), PACK1.IDENT(PACK1.TWO)) THEN + FAILED ("INCORRECT VALUE OF XAV1(" & + INTEGER'IMAGE(J) & ") (2)"); + END IF; + END LOOP; + + FOR J IN XAT1'RANGE LOOP + XAT1(J).VALU(I); + IF I /= IDENT_INT(2) THEN + FAILED ("INCORRECT RETURN VALUE FROM XAT1(" & + INTEGER'IMAGE(J) & ").VALU (2)"); + END IF; + END LOOP; + + CHK_TASK.ENTRY1(XRI1, XRA1, XRR1, XRP1, XRV1, XRT1, + XAI1, XAA1, XAR1, XAP1, XAV1, XAT1); + + IF XRI1 /= IDENT_INT(3) THEN + FAILED ("INCORRECT VALUE OF XRI1 (3)"); + END IF; + + IF XRA1 /= (IDENT_INT(3),IDENT_INT(3),IDENT_INT(3)) THEN + FAILED ("INCORRECT VALUE OF XRA1 (3)"); + END IF; + + IF XRR1 /= (D => 1, FIELD1 => IDENT_INT(3)) THEN + FAILED ("INCORRECT VALUE OF XRR1 (3)"); + END IF; + + IF XRP1 /= IDENT(REC.RP1) OR XRP1.ALL /= IDENT_INT(3) THEN + FAILED ("INCORRECT VALUE OF XRP1 (3)"); + END IF; + + IF PACK1."/=" (XRV1, PACK1.IDENT(PACK1.THREE)) THEN + FAILED ("INCORRECT VALUE OF XRV1 (3)"); + END IF; + + XRT1.VALU(I); + IF I /= IDENT_INT(3) THEN + FAILED ("INCORRECT RETURN VALUE OF XRT1.VALU (3)"); + END IF; + + FOR J IN XAI1'RANGE LOOP + IF XAI1(J) /= IDENT_INT(3) THEN + FAILED ("INCORRECT VALUE OF XAI1(" & + INTEGER'IMAGE(J) & ") (3)"); + END IF; + END LOOP; + + FOR J IN XAA1'RANGE LOOP + IF XAA1(J) /= (IDENT_INT(3),IDENT_INT(3),IDENT_INT(3)) + THEN + FAILED ("INCORRECT VALUE OF XAA1(" & + INTEGER'IMAGE(J) & ") (3)"); + END IF; + END LOOP; + + FOR J IN XAR1'RANGE LOOP + IF XAR1(J) /= (D => 1, FIELD1 => IDENT_INT(3)) THEN + FAILED ("INCORRECT VALUE OF XAR1(" & + INTEGER'IMAGE(J) & ") (3)"); + END IF; + END LOOP; + + FOR J IN XAP1'RANGE LOOP + IF XAP1(J) /= IDENT(AP1(J)) OR + XAP1(J).ALL /= IDENT_INT(3) THEN + FAILED ("INCORRECT VALUE OF XAP1(" & + INTEGER'IMAGE(J) & ") (3)"); + END IF; + END LOOP; + + FOR J IN XAV1'RANGE LOOP + IF PACK1."/=" (XAV1(J), PACK1.IDENT(PACK1.THREE)) THEN + FAILED ("INCORRECT VALUE OF XAV1(" & + INTEGER'IMAGE(J) & ") (3)"); + END IF; + END LOOP; + + FOR J IN XAT1'RANGE LOOP + XAT1(J).VALU(I); + IF I /= IDENT_INT(3) THEN + FAILED ("INCORRECT RETURN VALUE FROM XAT1(" & + INTEGER'IMAGE(J) & ").VALU (3)"); + END IF; + END LOOP; + + XRI1 := XRI1 + 1; + XRA1 := (XRA1(1)+1, XRA1(2)+1, XRA1(3)+1); + XRR1 := (D => 1, FIELD1 => XRR1.FIELD1 + 1); + XRP1 := NEW INTEGER'(XRP1.ALL + 1); + XRV1 := PACK1.NEXT(XRV1); + XRT1.NEXT; + XAI1 := (OTHERS => XAI1(XAI1'FIRST) + 1); + XAA1 := (OTHERS => (OTHERS => XAA1(XAA1'FIRST)(1) + 1)); + XAR1 := (OTHERS => (D => 1, + FIELD1 => (XAR1(XAR1'FIRST).FIELD1 + 1))); + XAP1 := (OTHERS => NEW INTEGER'(XAP1(XAP1'FIRST).ALL + 1)); + FOR J IN XAV1'RANGE LOOP + XAV1(J) := PACK1.NEXT(XAV1(J)); + END LOOP; + FOR J IN XAT1'RANGE LOOP + XAT1(J).NEXT; + END LOOP; + + IF XRI1 /= IDENT_INT(4) THEN + FAILED ("INCORRECT VALUE OF XRI1 (4)"); + END IF; + + IF XRA1 /= (IDENT_INT(4),IDENT_INT(4),IDENT_INT(4)) THEN + FAILED ("INCORRECT VALUE OF XRA1 (4)"); + END IF; + + IF XRR1 /= (D => 1, FIELD1 => IDENT_INT(4)) THEN + FAILED ("INCORRECT VALUE OF XRR1 (4)"); + END IF; + + IF XRP1 /= IDENT(REC.RP1) OR XRP1.ALL /= IDENT_INT(4) THEN + FAILED ("INCORRECT VALUE OF XRP1 (4)"); + END IF; + + IF PACK1."/=" (XRV1, PACK1.IDENT(PACK1.FOUR)) THEN + FAILED ("INCORRECT VALUE OF XRV1 (4)"); + END IF; + + XRT1.VALU(I); + IF I /= IDENT_INT(4) THEN + FAILED ("INCORRECT RETURN VALUE OF XRT1.VALU (4)"); + END IF; + + FOR J IN XAI1'RANGE LOOP + IF XAI1(J) /= IDENT_INT(4) THEN + FAILED ("INCORRECT VALUE OF XAI1(" & + INTEGER'IMAGE(J) & ") (4)"); + END IF; + END LOOP; + + FOR J IN XAA1'RANGE LOOP + IF XAA1(J) /= (IDENT_INT(4),IDENT_INT(4),IDENT_INT(4)) + THEN + FAILED ("INCORRECT VALUE OF XAA1(" & + INTEGER'IMAGE(J) & ") (4)"); + END IF; + END LOOP; + + FOR J IN XAR1'RANGE LOOP + IF XAR1(J) /= (D => 1, FIELD1 => IDENT_INT(4)) THEN + FAILED ("INCORRECT VALUE OF XAR1(" & + INTEGER'IMAGE(J) & ") (4)"); + END IF; + END LOOP; + + FOR J IN XAP1'RANGE LOOP + IF XAP1(J) /= IDENT(AP1(J)) OR + XAP1(J).ALL /= IDENT_INT(4) THEN + FAILED ("INCORRECT VALUE OF XAP1(" & + INTEGER'IMAGE(J) & ") (4)"); + END IF; + END LOOP; + + FOR J IN XAV1'RANGE LOOP + IF PACK1."/=" (XAV1(J), PACK1.IDENT(PACK1.FOUR)) THEN + FAILED ("INCORRECT VALUE OF XAV1(" & + INTEGER'IMAGE(J) & ") (4)"); + END IF; + END LOOP; + + FOR J IN XAT1'RANGE LOOP + XAT1(J).VALU(I); + IF I /= IDENT_INT(4) THEN + FAILED ("INCORRECT RETURN VALUE FROM XAT1(" & + INTEGER'IMAGE(J) & ").VALU (4)"); + END IF; + END LOOP; + + REC.RI1 := REC.RI1 + 1; + REC.RA1 := (REC.RA1(1)+1, REC.RA1(2)+1, REC.RA1(3)+1); + REC.RR1 := (D => 1, FIELD1 => REC.RR1.FIELD1 + 1); + REC.RP1 := NEW INTEGER'(REC.RP1.ALL + 1); + REC.RV1 := PACK1.NEXT(REC.RV1); + REC.RT1.NEXT; + AI1 := (OTHERS => AI1(XAI1'FIRST) + 1); + AA1 := (OTHERS => (OTHERS => AA1(XAA1'FIRST)(1) + 1)); + AR1 := (OTHERS => (D => 1, + FIELD1 => (AR1(XAR1'FIRST).FIELD1 + 1))); + AP1 := (OTHERS => NEW INTEGER'(AP1(XAP1'FIRST).ALL + 1)); + FOR J IN XAV1'RANGE LOOP + AV1(J) := PACK1.NEXT(AV1(J)); + END LOOP; + FOR J IN XAT1'RANGE LOOP + AT1(J).NEXT; + END LOOP; + + IF XRI1 /= IDENT_INT(5) THEN + FAILED ("INCORRECT VALUE OF XRI1 (5)"); + END IF; + + IF XRA1 /= (IDENT_INT(5),IDENT_INT(5),IDENT_INT(5)) THEN + FAILED ("INCORRECT VALUE OF XRA1 (5)"); + END IF; + + IF XRR1 /= (D => 1, FIELD1 => IDENT_INT(5)) THEN + FAILED ("INCORRECT VALUE OF XRR1 (5)"); + END IF; + + IF XRP1 /= IDENT(REC.RP1) OR XRP1.ALL /= IDENT_INT(5) THEN + FAILED ("INCORRECT VALUE OF XRP1 (5)"); + END IF; + + IF PACK1."/=" (XRV1, PACK1.IDENT(PACK1.FIVE)) THEN + FAILED ("INCORRECT VALUE OF XRV1 (5)"); + END IF; + + XRT1.VALU(I); + IF I /= IDENT_INT(5) THEN + FAILED ("INCORRECT RETURN VALUE OF XRT1.VALU (5)"); + END IF; + + FOR J IN XAI1'RANGE LOOP + IF XAI1(J) /= IDENT_INT(5) THEN + FAILED ("INCORRECT VALUE OF XAI1(" & + INTEGER'IMAGE(J) & ") (5)"); + END IF; + END LOOP; + + FOR J IN XAA1'RANGE LOOP + IF XAA1(J) /= (IDENT_INT(5),IDENT_INT(5),IDENT_INT(5)) + THEN + FAILED ("INCORRECT VALUE OF XAA1(" & + INTEGER'IMAGE(J) & ") (5)"); + END IF; + END LOOP; + + FOR J IN XAR1'RANGE LOOP + IF XAR1(J) /= (D => 1, FIELD1 => IDENT_INT(5)) THEN + FAILED ("INCORRECT VALUE OF XAR1(" & + INTEGER'IMAGE(J) & ") (5)"); + END IF; + END LOOP; + + FOR J IN XAP1'RANGE LOOP + IF XAP1(J) /= IDENT(AP1(J)) OR + XAP1(J).ALL /= IDENT_INT(5) THEN + FAILED ("INCORRECT VALUE OF XAP1(" & + INTEGER'IMAGE(J) & ") (5)"); + END IF; + END LOOP; + + FOR J IN XAV1'RANGE LOOP + IF PACK1."/=" (XAV1(J), PACK1.IDENT(PACK1.FIVE)) THEN + FAILED ("INCORRECT VALUE OF XAV1(" & + INTEGER'IMAGE(J) & ") (5)"); + END IF; + END LOOP; + + FOR J IN XAT1'RANGE LOOP + XAT1(J).VALU(I); + IF I /= IDENT_INT(5) THEN + FAILED ("INCORRECT RETURN VALUE FROM XAT1(" & + INTEGER'IMAGE(J) & ").VALU (5)"); + END IF; + END LOOP; + END GENERIC1; + + TASK BODY TASK1 IS + TASK_VALUE : INTEGER := 0; + ACCEPTING_ENTRIES : BOOLEAN := TRUE; + BEGIN + WHILE ACCEPTING_ENTRIES LOOP + SELECT + ACCEPT ASSIGN (J : IN INTEGER) DO + TASK_VALUE := J; + END ASSIGN; + OR + ACCEPT VALU (J : OUT INTEGER) DO + J := TASK_VALUE; + END VALU; + OR + ACCEPT NEXT DO + TASK_VALUE := TASK_VALUE + 1; + END NEXT; + OR + ACCEPT STOP DO + ACCEPTING_ENTRIES := FALSE; + END STOP; + END SELECT; + END LOOP; + END TASK1; + +BEGIN + TEST ("C85006D", "CHECK THAT A COMPONENT OR SLICE OF A VARIABLE " & + "CREATED BY A GENERIC 'IN OUT' FORMAL " & + "PARAMETER CAN BE RENAMED AND HAS THE CORRECT " & + "VALUE, AND THAT THE NEW NAME CAN BE USED IN " & + "AN ASSIGNMENT STATEMENT AND PASSED ON AS AN " & + "ACTUAL SUBPROGRAM OR ENTRY 'IN OUT' OR 'OUT' " & + "PARAMETER, AND AS AN ACTUAL GENERIC 'IN OUT' " & + "PARAMETER, AND THAT WHEN THE VALUE OF THE " & + "RENAMED VARIABLE IS CHANGED, THE NEW VALUE IS " & + "REFLECTED BY THE VALUE OF THE NEW NAME"); + + DECLARE + PACKAGE GENPACK IS NEW + GENERIC1 (DREC, DAI1, DAA1, DAR1, DAP1, DAV1, DAT1); + BEGIN + NULL; + END; + + DREC.RT1.STOP; + + FOR I IN DAT1'RANGE LOOP + DAT1(I).STOP; + END LOOP; + + RESULT; +END C85006D; diff --git a/gcc/testsuite/ada/acats/tests/c8/c85006e.ada b/gcc/testsuite/ada/acats/tests/c8/c85006e.ada new file mode 100644 index 000000000..3c920039d --- /dev/null +++ b/gcc/testsuite/ada/acats/tests/c8/c85006e.ada @@ -0,0 +1,702 @@ +-- C85006E.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 A COMPONENT OR SLICE OF A VARIABLE CREATED BY AN +-- ALLOCATOR CAN BE RENAMED AND HAS THE CORRECT VALUE, +-- AND THAT THE NEW NAME CAN BE USED IN AN ASSIGNMENT STATEMENT +-- AND PASSED ON AS AN ACTUAL SUBPROGRAM OR ENTRY 'IN OUT' OR 'OUT' +-- PARAMETER, AND AS AN ACTUAL GENERIC 'IN OUT' PARAMETER, +-- AND THAT WHEN THE VALUE OF THE RENAMED VARIABLE IS CHANGED, +-- THE NEW VALUE IS REFLECTED BY THE VALUE OF THE NEW NAME. + +-- HISTORY: +-- JET 03/22/88 CREATED ORIGINAL TEST. + +WITH REPORT; USE REPORT; +PROCEDURE C85006E IS + + TYPE ARRAY1 IS ARRAY (POSITIVE RANGE <>) OF INTEGER; + TYPE RECORD1 (D : INTEGER) IS + RECORD + FIELD1 : INTEGER := 1; + END RECORD; + TYPE POINTER1 IS ACCESS INTEGER; + + PACKAGE PACK1 IS + TYPE PRIVY IS PRIVATE; + ZERO : CONSTANT PRIVY; + ONE : CONSTANT PRIVY; + TWO : CONSTANT PRIVY; + THREE : CONSTANT PRIVY; + FOUR : CONSTANT PRIVY; + FIVE : CONSTANT PRIVY; + FUNCTION IDENT (I : PRIVY) RETURN PRIVY; + FUNCTION NEXT (I : PRIVY) RETURN PRIVY; + PRIVATE + TYPE PRIVY IS RANGE 0..127; + ZERO : CONSTANT PRIVY := 0; + ONE : CONSTANT PRIVY := 1; + TWO : CONSTANT PRIVY := 2; + THREE : CONSTANT PRIVY := 3; + FOUR : CONSTANT PRIVY := 4; + FIVE : CONSTANT PRIVY := 5; + END PACK1; + + TASK TYPE TASK1 IS + ENTRY ASSIGN (J : IN INTEGER); + ENTRY VALU (J : OUT INTEGER); + ENTRY NEXT; + ENTRY STOP; + END TASK1; + + TYPE ARR_INT IS ARRAY(POSITIVE RANGE <>) OF INTEGER; + TYPE ARR_ARR IS ARRAY(POSITIVE RANGE <>) OF ARRAY1(1..3); + TYPE ARR_REC IS ARRAY(POSITIVE RANGE <>) OF RECORD1(1); + TYPE ARR_PTR IS ARRAY(POSITIVE RANGE <>) OF POINTER1; + TYPE ARR_PVT IS ARRAY(POSITIVE RANGE <>) OF PACK1.PRIVY; + TYPE ARR_TSK IS ARRAY(POSITIVE RANGE <>) OF TASK1; + + TYPE REC_TYPE IS RECORD + RI1 : INTEGER := 0; + RA1 : ARRAY1(1..3) := (OTHERS => 0); + RR1 : RECORD1(1) := (D => 1, FIELD1 => 0); + RP1 : POINTER1 := NEW INTEGER'(0); + RV1 : PACK1.PRIVY := PACK1.ZERO; + RT1 : TASK1; + END RECORD; + + GENERIC + GRI1 : IN OUT INTEGER; + GRA1 : IN OUT ARRAY1; + GRR1 : IN OUT RECORD1; + GRP1 : IN OUT POINTER1; + GRV1 : IN OUT PACK1.PRIVY; + GRT1 : IN OUT TASK1; + GAI1 : IN OUT ARR_INT; + GAA1 : IN OUT ARR_ARR; + GAR1 : IN OUT ARR_REC; + GAP1 : IN OUT ARR_PTR; + GAV1 : IN OUT ARR_PVT; + GAT1 : IN OUT ARR_TSK; + PACKAGE GENERIC1 IS + END GENERIC1; + + FUNCTION IDENT (P : POINTER1) RETURN POINTER1 IS + BEGIN + IF EQUAL (3,3) THEN + RETURN P; + ELSE + RETURN NULL; + END IF; + END IDENT; + + PACKAGE BODY PACK1 IS + FUNCTION IDENT (I : PRIVY) RETURN PRIVY IS + BEGIN + IF EQUAL(3,3) THEN + RETURN I; + ELSE + RETURN PRIVY'(0); + END IF; + END IDENT; + + FUNCTION NEXT (I : PRIVY) RETURN PRIVY IS + BEGIN + RETURN I+1; + END NEXT; + END PACK1; + + PACKAGE BODY GENERIC1 IS + BEGIN + GRI1 := GRI1 + 1; + GRA1 := (GRA1(1)+1, GRA1(2)+1, GRA1(3)+1); + GRR1 := (D => 1, FIELD1 => GRR1.FIELD1+1); + GRP1 := NEW INTEGER'(GRP1.ALL + 1); + GRV1 := PACK1.NEXT(GRV1); + GRT1.NEXT; + GAI1 := (OTHERS => GAI1(GAI1'FIRST) + 1); + GAA1 := (OTHERS => (OTHERS => GAA1(GAA1'FIRST)(1) + 1)); + GAR1 := (OTHERS => (D => 1, + FIELD1 => (GAR1(GAR1'FIRST).FIELD1 + 1))); + GAP1 := (OTHERS => NEW INTEGER'(GAP1(GAP1'FIRST).ALL + 1)); + FOR J IN GAV1'RANGE LOOP + GAV1(J) := PACK1.NEXT(GAV1(J)); + END LOOP; + FOR J IN GAT1'RANGE LOOP + GAT1(J).NEXT; + END LOOP; + END GENERIC1; + + TASK BODY TASK1 IS + TASK_VALUE : INTEGER := 0; + ACCEPTING_ENTRIES : BOOLEAN := TRUE; + BEGIN + WHILE ACCEPTING_ENTRIES LOOP + SELECT + ACCEPT ASSIGN (J : IN INTEGER) DO + TASK_VALUE := J; + END ASSIGN; + OR + ACCEPT VALU (J : OUT INTEGER) DO + J := TASK_VALUE; + END VALU; + OR + ACCEPT NEXT DO + TASK_VALUE := TASK_VALUE + 1; + END NEXT; + OR + ACCEPT STOP DO + ACCEPTING_ENTRIES := FALSE; + END STOP; + END SELECT; + END LOOP; + END TASK1; + +BEGIN + TEST ("C85006E", "CHECK THAT A COMPONENT OR SLICE OF A VARIABLE " & + "CREATED BY AN ALLOCATOR CAN BE " & + "RENAMED AND HAS THE CORRECT VALUE, AND THAT " & + "THE NEW NAME CAN BE USED IN AN ASSIGNMENT " & + "STATEMENT AND PASSED ON AS AN ACTUAL " & + "SUBPROGRAM OR ENTRY 'IN OUT' OR 'OUT' " & + "PARAMETER, AND AS AN ACTUAL GENERIC 'IN OUT' " & + "PARAMETER, AND THAT WHEN THE VALUE OF THE " & + "RENAMED VARIABLE IS CHANGED, THE NEW VALUE IS " & + "REFLECTED BY THE VALUE OF THE NEW NAME"); + + DECLARE + TYPE AREC_TYPE IS ACCESS REC_TYPE; + AREC : AREC_TYPE := NEW REC_TYPE; + + TYPE ACC_INT IS ACCESS ARR_INT; + TYPE ACC_ARR IS ACCESS ARR_ARR; + TYPE ACC_REC IS ACCESS ARR_REC; + TYPE ACC_PTR IS ACCESS ARR_PTR; + TYPE ACC_PVT IS ACCESS ARR_PVT; + TYPE ACC_TSK IS ACCESS ARR_TSK; + + AI1 : ACC_INT := NEW ARR_INT'(1..8 => 0); + AA1 : ACC_ARR := NEW ARR_ARR'(1..8 => (OTHERS => 0)); + AR1 : ACC_REC := NEW ARR_REC'(1..8 => (D => 1, FIELD1 => 0)); + AP1 : ACC_PTR := NEW ARR_PTR'(1..8 => NEW INTEGER'(0)); + AV1 : ACC_PVT := NEW ARR_PVT'(1..8 => PACK1.ZERO); + AT1 : ACC_TSK := NEW ARR_TSK(1..8); + + XRI1 : INTEGER RENAMES AREC.RI1; + XRA1 : ARRAY1 RENAMES AREC.RA1; + XRR1 : RECORD1 RENAMES AREC.RR1; + XRP1 : POINTER1 RENAMES AREC.RP1; + XRV1 : PACK1.PRIVY RENAMES AREC.RV1; + XRT1 : TASK1 RENAMES AREC.RT1; + XAI1 : ARR_INT RENAMES AI1(1..3); + XAA1 : ARR_ARR RENAMES AA1(2..4); + XAR1 : ARR_REC RENAMES AR1(3..5); + XAP1 : ARR_PTR RENAMES AP1(4..6); + XAV1 : ARR_PVT RENAMES AV1(5..7); + XAT1 : ARR_TSK RENAMES AT1(6..8); + + TASK TYPE TASK2 IS + ENTRY ENTRY1 (TRI1 : OUT INTEGER; TRA1 : OUT ARRAY1; + TRR1 : OUT RECORD1; TRP1 : IN OUT POINTER1; + TRV1 : IN OUT PACK1.PRIVY; + TRT1 : IN OUT TASK1; + TAI1 : OUT ARR_INT; TAA1 : OUT ARR_ARR; + TAR1 : OUT ARR_REC; TAP1 : IN OUT ARR_PTR; + TAV1 : IN OUT ARR_PVT; + TAT1 : IN OUT ARR_TSK); + END TASK2; + + I : INTEGER; + CHK_TASK : TASK2; + + PROCEDURE PROC1 (PRI1 : IN OUT INTEGER; PRA1 : IN OUT ARRAY1; + PRR1 : IN OUT RECORD1; PRP1 : OUT POINTER1; + PRV1 : OUT PACK1.PRIVY; PRT1 : IN OUT TASK1; + PAI1 : IN OUT ARR_INT; PAA1 : IN OUT ARR_ARR; + PAR1 : IN OUT ARR_REC; PAP1 : OUT ARR_PTR; + PAV1 : OUT ARR_PVT; PAT1 : IN OUT ARR_TSK) IS + BEGIN + PRI1 := PRI1 + 1; + PRA1 := (PRA1(1)+1, PRA1(2)+1, PRA1(3)+1); + PRR1 := (D => 1, FIELD1 => PRR1.FIELD1 + 1); + PRP1 := NEW INTEGER'(AREC.RP1.ALL + 1); + PRV1 := PACK1.NEXT(AREC.RV1); + PRT1.NEXT; + PAI1 := (OTHERS => PAI1(PAI1'FIRST) + 1); + PAA1 := (OTHERS => (OTHERS => PAA1(PAA1'FIRST)(1) + 1)); + PAR1 := (OTHERS => (D => 1, FIELD1 => + (PAR1(PAR1'FIRST).FIELD1 + 1))); + PAP1 := (OTHERS => + NEW INTEGER'(AP1(PAP1'FIRST).ALL + 1)); + FOR J IN PAV1'RANGE LOOP + PAV1(J) := PACK1.NEXT(AV1(J)); + END LOOP; + FOR J IN PAT1'RANGE LOOP + PAT1(J).NEXT; + END LOOP; + END PROC1; + + TASK BODY TASK2 IS + BEGIN + ACCEPT ENTRY1 (TRI1 : OUT INTEGER; TRA1 : OUT ARRAY1; + TRR1 : OUT RECORD1; + TRP1 : IN OUT POINTER1; + TRV1 : IN OUT PACK1.PRIVY; + TRT1: IN OUT TASK1; + TAI1 : OUT ARR_INT; TAA1 : OUT ARR_ARR; + TAR1 : OUT ARR_REC; TAP1 : IN OUT ARR_PTR; + TAV1 : IN OUT ARR_PVT; + TAT1 : IN OUT ARR_TSK) + DO + TRI1 := AREC.RI1 + 1; + TRA1 := (AREC.RA1(1)+1, AREC.RA1(2)+1, + AREC.RA1(3)+1); + TRR1 := (D => 1, FIELD1 => AREC.RR1.FIELD1 + 1); + TRP1 := NEW INTEGER'(TRP1.ALL + 1); + TRV1 := PACK1.NEXT(TRV1); + TRT1.NEXT; + TAI1 := (OTHERS => AI1(TAI1'FIRST) + 1); + TAA1 := (OTHERS => (OTHERS => + AA1(TAA1'FIRST)(1) + 1)); + TAR1 := (OTHERS => (D => 1, FIELD1 => + (AR1(TAR1'FIRST).FIELD1 + 1))); + TAP1 := (OTHERS => + NEW INTEGER'(TAP1(TAP1'FIRST).ALL+1)); + FOR J IN TAV1'RANGE LOOP + TAV1(J) := PACK1.NEXT(TAV1(J)); + END LOOP; + FOR J IN TAT1'RANGE LOOP + TAT1(J).NEXT; + END LOOP; + END ENTRY1; + END TASK2; + + PACKAGE GENPACK2 IS NEW + GENERIC1 (XRI1, XRA1, XRR1, XRP1, XRV1, XRT1, + XAI1, XAA1, XAR1, XAP1, XAV1, XAT1); + BEGIN + IF XRI1 /= IDENT_INT(1) THEN + FAILED ("INCORRECT VALUE OF XRI1 (1)"); + END IF; + + IF XRA1 /= (IDENT_INT(1),IDENT_INT(1),IDENT_INT(1)) THEN + FAILED ("INCORRECT VALUE OF XRA1 (1)"); + END IF; + + IF XRR1 /= (D => 1, FIELD1 => IDENT_INT(1)) THEN + FAILED ("INCORRECT VALUE OF XRR1 (1)"); + END IF; + + IF XRP1 /= IDENT(AREC.RP1) OR XRP1.ALL /= IDENT_INT(1) THEN + FAILED ("INCORRECT VALUE OF XRP1 (1)"); + END IF; + + IF PACK1."/=" (XRV1, PACK1.IDENT(PACK1.ONE)) THEN + FAILED ("INCORRECT VALUE OF XRV1 (1)"); + END IF; + + XRT1.VALU(I); + IF I /= IDENT_INT(1) THEN + FAILED ("INCORRECT RETURN VALUE OF XRT1.VALU (1)"); + END IF; + + FOR J IN XAI1'RANGE LOOP + IF XAI1(J) /= IDENT_INT(1) THEN + FAILED ("INCORRECT VALUE OF XAI1(" & + INTEGER'IMAGE(J) & ") (1)"); + END IF; + END LOOP; + + FOR J IN XAA1'RANGE LOOP + IF XAA1(J) /= (IDENT_INT(1),IDENT_INT(1),IDENT_INT(1)) + THEN + FAILED ("INCORRECT VALUE OF XAA1(" & + INTEGER'IMAGE(J) & ") (1)"); + END IF; + END LOOP; + + FOR J IN XAR1'RANGE LOOP + IF XAR1(J) /= (D => 1, FIELD1 => IDENT_INT(1)) THEN + FAILED ("INCORRECT VALUE OF XAR1(" & + INTEGER'IMAGE(J) & ") (1)"); + END IF; + END LOOP; + + FOR J IN XAP1'RANGE LOOP + IF XAP1(J) /= IDENT(AP1(J)) OR + XAP1(J).ALL /= IDENT_INT(1) THEN + FAILED ("INCORRECT VALUE OF XAP1(" & + INTEGER'IMAGE(J) & ") (1)"); + END IF; + END LOOP; + + FOR J IN XAV1'RANGE LOOP + IF PACK1."/=" (XAV1(J), PACK1.IDENT(PACK1.ONE)) THEN + FAILED ("INCORRECT VALUE OF XAV1(" & + INTEGER'IMAGE(J) & ") (1)"); + END IF; + END LOOP; + + FOR J IN XAT1'RANGE LOOP + XAT1(J).VALU(I); + IF I /= IDENT_INT(1) THEN + FAILED ("INCORRECT RETURN VALUE FROM XAT1(" & + INTEGER'IMAGE(J) & ").VALU (1)"); + END IF; + END LOOP; + + PROC1 (XRI1, XRA1, XRR1, XRP1, XRV1, XRT1, + XAI1, XAA1, XAR1, XAP1, XAV1, XAT1); + + IF XRI1 /= IDENT_INT(2) THEN + FAILED ("INCORRECT VALUE OF XRI1 (2)"); + END IF; + + IF XRA1 /= (IDENT_INT(2),IDENT_INT(2),IDENT_INT(2)) THEN + FAILED ("INCORRECT VALUE OF XRA1 (2)"); + END IF; + + IF XRR1 /= (D => 1, FIELD1 => IDENT_INT(2)) THEN + FAILED ("INCORRECT VALUE OF XRR1 (2)"); + END IF; + + IF XRP1 /= IDENT(AREC.RP1) OR XRP1.ALL /= IDENT_INT(2) THEN + FAILED ("INCORRECT VALUE OF XRP1 (2)"); + END IF; + + IF PACK1."/=" (XRV1, PACK1.IDENT(PACK1.TWO)) THEN + FAILED ("INCORRECT VALUE OF XRV1 (2)"); + END IF; + + XRT1.VALU(I); + IF I /= IDENT_INT(2) THEN + FAILED ("INCORRECT RETURN VALUE FROM XRT1.VALU (2)"); + END IF; + + FOR J IN XAI1'RANGE LOOP + IF XAI1(J) /= IDENT_INT(2) THEN + FAILED ("INCORRECT VALUE OF XAI1(" & + INTEGER'IMAGE(J) & ") (2)"); + END IF; + END LOOP; + + FOR J IN XAA1'RANGE LOOP + IF XAA1(J) /= (IDENT_INT(2),IDENT_INT(2),IDENT_INT(2)) + THEN + FAILED ("INCORRECT VALUE OF XAA1(" & + INTEGER'IMAGE(J) & ") (2)"); + END IF; + END LOOP; + + FOR J IN XAR1'RANGE LOOP + IF XAR1(J) /= (D => 1, FIELD1 => IDENT_INT(2)) THEN + FAILED ("INCORRECT VALUE OF XAR1(" & + INTEGER'IMAGE(J) & ") (2)"); + END IF; + END LOOP; + + FOR J IN XAP1'RANGE LOOP + IF XAP1(J) /= IDENT(AP1(J)) OR + XAP1(J).ALL /= IDENT_INT(2) THEN + FAILED ("INCORRECT VALUE OF XAP1(" & + INTEGER'IMAGE(J) & ") (2)"); + END IF; + END LOOP; + + FOR J IN XAV1'RANGE LOOP + IF PACK1."/=" (XAV1(J), PACK1.IDENT(PACK1.TWO)) THEN + FAILED ("INCORRECT VALUE OF XAV1(" & + INTEGER'IMAGE(J) & ") (2)"); + END IF; + END LOOP; + + FOR J IN XAT1'RANGE LOOP + XAT1(J).VALU(I); + IF I /= IDENT_INT(2) THEN + FAILED ("INCORRECT RETURN VALUE FROM XAT1(" & + INTEGER'IMAGE(J) & ").VALU (2)"); + END IF; + END LOOP; + + CHK_TASK.ENTRY1(XRI1, XRA1, XRR1, XRP1, XRV1, XRT1, + XAI1, XAA1, XAR1, XAP1, XAV1, XAT1); + + IF XRI1 /= IDENT_INT(3) THEN + FAILED ("INCORRECT VALUE OF XRI1 (3)"); + END IF; + + IF XRA1 /= (IDENT_INT(3),IDENT_INT(3),IDENT_INT(3)) THEN + FAILED ("INCORRECT VALUE OF XRA1 (3)"); + END IF; + + IF XRR1 /= (D => 1, FIELD1 => IDENT_INT(3)) THEN + FAILED ("INCORRECT VALUE OF XRR1 (3)"); + END IF; + + IF XRP1 /= IDENT(AREC.RP1) OR XRP1.ALL /= IDENT_INT(3) THEN + FAILED ("INCORRECT VALUE OF XRP1 (3)"); + END IF; + + IF PACK1."/=" (XRV1, PACK1.IDENT(PACK1.THREE)) THEN + FAILED ("INCORRECT VALUE OF XRV1 (3)"); + END IF; + + XRT1.VALU(I); + IF I /= IDENT_INT(3) THEN + FAILED ("INCORRECT RETURN VALUE OF XRT1.VALU (3)"); + END IF; + + FOR J IN XAI1'RANGE LOOP + IF XAI1(J) /= IDENT_INT(3) THEN + FAILED ("INCORRECT VALUE OF XAI1(" & + INTEGER'IMAGE(J) & ") (3)"); + END IF; + END LOOP; + + FOR J IN XAA1'RANGE LOOP + IF XAA1(J) /= (IDENT_INT(3),IDENT_INT(3),IDENT_INT(3)) + THEN + FAILED ("INCORRECT VALUE OF XAA1(" & + INTEGER'IMAGE(J) & ") (3)"); + END IF; + END LOOP; + + FOR J IN XAR1'RANGE LOOP + IF XAR1(J) /= (D => 1, FIELD1 => IDENT_INT(3)) THEN + FAILED ("INCORRECT VALUE OF XAR1(" & + INTEGER'IMAGE(J) & ") (3)"); + END IF; + END LOOP; + + FOR J IN XAP1'RANGE LOOP + IF XAP1(J) /= IDENT(AP1(J)) OR + XAP1(J).ALL /= IDENT_INT(3) THEN + FAILED ("INCORRECT VALUE OF XAP1(" & + INTEGER'IMAGE(J) & ") (3)"); + END IF; + END LOOP; + + FOR J IN XAV1'RANGE LOOP + IF PACK1."/=" (XAV1(J), PACK1.IDENT(PACK1.THREE)) THEN + FAILED ("INCORRECT VALUE OF XAV1(" & + INTEGER'IMAGE(J) & ") (3)"); + END IF; + END LOOP; + + FOR J IN XAT1'RANGE LOOP + XAT1(J).VALU(I); + IF I /= IDENT_INT(3) THEN + FAILED ("INCORRECT RETURN VALUE FROM XAT1(" & + INTEGER'IMAGE(J) & ").VALU (3)"); + END IF; + END LOOP; + + XRI1 := XRI1 + 1; + XRA1 := (XRA1(1)+1, XRA1(2)+1, XRA1(3)+1); + XRR1 := (D => 1, FIELD1 => XRR1.FIELD1 + 1); + XRP1 := NEW INTEGER'(XRP1.ALL + 1); + XRV1 := PACK1.NEXT(XRV1); + XRT1.NEXT; + XAI1 := (OTHERS => XAI1(XAI1'FIRST) + 1); + XAA1 := (OTHERS => (OTHERS => XAA1(XAA1'FIRST)(1) + 1)); + XAR1 := (OTHERS => (D => 1, + FIELD1 => (XAR1(XAR1'FIRST).FIELD1 + 1))); + XAP1 := (OTHERS => NEW INTEGER'(XAP1(XAP1'FIRST).ALL + 1)); + FOR J IN XAV1'RANGE LOOP + XAV1(J) := PACK1.NEXT(XAV1(J)); + END LOOP; + FOR J IN XAT1'RANGE LOOP + XAT1(J).NEXT; + END LOOP; + + IF XRI1 /= IDENT_INT(4) THEN + FAILED ("INCORRECT VALUE OF XRI1 (4)"); + END IF; + + IF XRA1 /= (IDENT_INT(4),IDENT_INT(4),IDENT_INT(4)) THEN + FAILED ("INCORRECT VALUE OF XRA1 (4)"); + END IF; + + IF XRR1 /= (D => 1, FIELD1 => IDENT_INT(4)) THEN + FAILED ("INCORRECT VALUE OF XRR1 (4)"); + END IF; + + IF XRP1 /= IDENT(AREC.RP1) OR XRP1.ALL /= IDENT_INT(4) THEN + FAILED ("INCORRECT VALUE OF XRP1 (4)"); + END IF; + + IF PACK1."/=" (XRV1, PACK1.IDENT(PACK1.FOUR)) THEN + FAILED ("INCORRECT VALUE OF XRV1 (4)"); + END IF; + + XRT1.VALU(I); + IF I /= IDENT_INT(4) THEN + FAILED ("INCORRECT RETURN VALUE OF XRT1.VALU (4)"); + END IF; + + FOR J IN XAI1'RANGE LOOP + IF XAI1(J) /= IDENT_INT(4) THEN + FAILED ("INCORRECT VALUE OF XAI1(" & + INTEGER'IMAGE(J) & ") (4)"); + END IF; + END LOOP; + + FOR J IN XAA1'RANGE LOOP + IF XAA1(J) /= (IDENT_INT(4),IDENT_INT(4),IDENT_INT(4)) + THEN + FAILED ("INCORRECT VALUE OF XAA1(" & + INTEGER'IMAGE(J) & ") (4)"); + END IF; + END LOOP; + + FOR J IN XAR1'RANGE LOOP + IF XAR1(J) /= (D => 1, FIELD1 => IDENT_INT(4)) THEN + FAILED ("INCORRECT VALUE OF XAR1(" & + INTEGER'IMAGE(J) & ") (4)"); + END IF; + END LOOP; + + FOR J IN XAP1'RANGE LOOP + IF XAP1(J) /= IDENT(AP1(J)) OR + XAP1(J).ALL /= IDENT_INT(4) THEN + FAILED ("INCORRECT VALUE OF XAP1(" & + INTEGER'IMAGE(J) & ") (4)"); + END IF; + END LOOP; + + FOR J IN XAV1'RANGE LOOP + IF PACK1."/=" (XAV1(J), PACK1.IDENT(PACK1.FOUR)) THEN + FAILED ("INCORRECT VALUE OF XAV1(" & + INTEGER'IMAGE(J) & ") (4)"); + END IF; + END LOOP; + + FOR J IN XAT1'RANGE LOOP + XAT1(J).VALU(I); + IF I /= IDENT_INT(4) THEN + FAILED ("INCORRECT RETURN VALUE FROM XAT1(" & + INTEGER'IMAGE(J) & ").VALU (4)"); + END IF; + END LOOP; + + AREC.RI1 := AREC.RI1 + 1; + AREC.RA1 := (AREC.RA1(1)+1, AREC.RA1(2)+1, AREC.RA1(3)+1); + AREC.RR1 := (D => 1, FIELD1 => AREC.RR1.FIELD1 + 1); + AREC.RP1 := NEW INTEGER'(AREC.RP1.ALL + 1); + AREC.RV1 := PACK1.NEXT(AREC.RV1); + AREC.RT1.NEXT; + AI1(XAI1'RANGE) := (OTHERS => AI1(XAI1'FIRST) + 1); + AA1(XAA1'RANGE) := (OTHERS => + (OTHERS => AA1(XAA1'FIRST)(1) + 1)); + AR1(XAR1'RANGE) := (OTHERS => (D => 1, + FIELD1 => (AR1(XAR1'FIRST).FIELD1 + 1))); + AP1(XAP1'RANGE) := (OTHERS => + NEW INTEGER'(AP1(XAP1'FIRST).ALL + 1)); + FOR J IN XAV1'RANGE LOOP + AV1(J) := PACK1.NEXT(AV1(J)); + END LOOP; + FOR J IN XAT1'RANGE LOOP + AT1(J).NEXT; + END LOOP; + + IF XRI1 /= IDENT_INT(5) THEN + FAILED ("INCORRECT VALUE OF XRI1 (5)"); + END IF; + + IF XRA1 /= (IDENT_INT(5),IDENT_INT(5),IDENT_INT(5)) THEN + FAILED ("INCORRECT VALUE OF XRA1 (5)"); + END IF; + + IF XRR1 /= (D => 1, FIELD1 => IDENT_INT(5)) THEN + FAILED ("INCORRECT VALUE OF XRR1 (5)"); + END IF; + + IF XRP1 /= IDENT(AREC.RP1) OR XRP1.ALL /= IDENT_INT(5) THEN + FAILED ("INCORRECT VALUE OF XRP1 (5)"); + END IF; + + IF PACK1."/=" (XRV1, PACK1.IDENT(PACK1.FIVE)) THEN + FAILED ("INCORRECT VALUE OF XRV1 (5)"); + END IF; + + XRT1.VALU(I); + IF I /= IDENT_INT(5) THEN + FAILED ("INCORRECT RETURN VALUE OF XRT1.VALU (5)"); + END IF; + + FOR J IN XAI1'RANGE LOOP + IF XAI1(J) /= IDENT_INT(5) THEN + FAILED ("INCORRECT VALUE OF XAI1(" & + INTEGER'IMAGE(J) & ") (5)"); + END IF; + END LOOP; + + FOR J IN XAA1'RANGE LOOP + IF XAA1(J) /= (IDENT_INT(5),IDENT_INT(5),IDENT_INT(5)) + THEN + FAILED ("INCORRECT VALUE OF XAA1(" & + INTEGER'IMAGE(J) & ") (5)"); + END IF; + END LOOP; + + FOR J IN XAR1'RANGE LOOP + IF XAR1(J) /= (D => 1, FIELD1 => IDENT_INT(5)) THEN + FAILED ("INCORRECT VALUE OF XAR1(" & + INTEGER'IMAGE(J) & ") (5)"); + END IF; + END LOOP; + + FOR J IN XAP1'RANGE LOOP + IF XAP1(J) /= IDENT(AP1(J)) OR + XAP1(J).ALL /= IDENT_INT(5) THEN + FAILED ("INCORRECT VALUE OF XAP1(" & + INTEGER'IMAGE(J) & ") (5)"); + END IF; + END LOOP; + + FOR J IN XAV1'RANGE LOOP + IF PACK1."/=" (XAV1(J), PACK1.IDENT(PACK1.FIVE)) THEN + FAILED ("INCORRECT VALUE OF XAV1(" & + INTEGER'IMAGE(J) & ") (5)"); + END IF; + END LOOP; + + FOR J IN XAT1'RANGE LOOP + XAT1(J).VALU(I); + IF I /= IDENT_INT(5) THEN + FAILED ("INCORRECT RETURN VALUE FROM XAT1(" & + INTEGER'IMAGE(J) & ").VALU (5)"); + END IF; + END LOOP; + + AREC.RT1.STOP; + + FOR I IN AT1'RANGE LOOP + AT1(I).STOP; + END LOOP; + END; + + RESULT; +END C85006E; diff --git a/gcc/testsuite/ada/acats/tests/c8/c85006f.ada b/gcc/testsuite/ada/acats/tests/c8/c85006f.ada new file mode 100644 index 000000000..bbfe63e92 --- /dev/null +++ b/gcc/testsuite/ada/acats/tests/c8/c85006f.ada @@ -0,0 +1,70 @@ +-- C85006F.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 A RENAMED SLICE CAN BE SLICED AND INDEXED FOR PURPOSES +-- OF ASSIGNMENT AND TO READ THE VALUE. + +-- HISTORY: +-- JET 07/26/88 CREATED ORIGINAL TEST. + +WITH REPORT; USE REPORT; +PROCEDURE C85006F IS + + S : STRING(1..30) := "IT WAS A DARK AND STORMY NIGHT"; + + ADJECTIVES : STRING RENAMES S(10..24); + +BEGIN + TEST ("C85006F", "CHECK THAT A RENAMED SLICE CAN BE SLICED AND " & + "INDEXED FOR PURPOSES OF ASSIGNMENT AND TO " & + "READ THE VALUE"); + + ADJECTIVES(19..24) := "STARRY"; + + IF ADJECTIVES /= IDENT_STR("DARK AND STARRY") THEN + FAILED ("INCORRECT VALUE OF SLICE AFTER ASSIGNMENT (1)"); + END IF; + + IF S /= IDENT_STR("IT WAS A DARK AND STARRY NIGHT") THEN + FAILED ("INCORRECT VALUE OF ORIGINAL STRING (1)"); + END IF; + + ADJECTIVES(17) := '''; + + IF ADJECTIVES /= IDENT_STR("DARK AN' STARRY") THEN + FAILED ("INCORRECT VALUE OF SLICE AFTER ASSIGNMENT (2)"); + END IF; + + IF S /= IDENT_STR("IT WAS A DARK AN' STARRY NIGHT") THEN + FAILED ("INCORRECT VALUE OF ORIGINAL STRING (2)"); + END IF; + + IF ADJECTIVES(10..13) /= IDENT_STR("DARK") THEN + FAILED ("INCORRECT VALUE OF SLICE WHEN READING"); + END IF; + + RESULT; + +END C85006F; diff --git a/gcc/testsuite/ada/acats/tests/c8/c85006g.ada b/gcc/testsuite/ada/acats/tests/c8/c85006g.ada new file mode 100644 index 000000000..9d6d59f5e --- /dev/null +++ b/gcc/testsuite/ada/acats/tests/c8/c85006g.ada @@ -0,0 +1,136 @@ +-- C85006G.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 ANY SUBTYPE CONSTRAINT IMPOSED BY THE TYPE MARK USED +-- IN THE SLICE RENAMING DECLARATION IS IGNORED, AND THAT THE +-- SUBTYPE CONSTRAINT ASSOCIATED WITH THE RENAMED VARIABLE IS +-- USED INSTEAD. + +-- HISTORY: +-- JET 07/26/88 CREATED ORIGINAL TEST. + +WITH REPORT; USE REPORT; +PROCEDURE C85006G IS + + SUBTYPE STR IS STRING(1..10); + + S : STRING(1..30) := IDENT_STR("IT WAS A DARK AND STORMY NIGHT"); + T : STR := IDENT_STR("0123456789"); + + DG1 : STRING(1..30) := IDENT_STR("IT WAS A DARK AND STORMY NIGHT"); + DG2 : STR := IDENT_STR("0123456789"); + + XS : STR RENAMES S(10..24); + XT : STRING RENAMES T(1..5); + + GENERIC + G1 : IN OUT STR; + G2 : IN OUT STRING; + PACKAGE GEN IS + XG1 : STR RENAMES G1(10..24); + XG2 : STRING RENAMES G2(1..5); + END GEN; + + PACKAGE PACK IS NEW GEN(DG1, DG2); + USE PACK; + +BEGIN + TEST ("C85006G", "CHECK THAT ANY SUBTYPE CONSTRAINT IMPOSED BY " & + "THE TYPE MARK USED IN THE SLICE RENAMING " & + "DECLARATION IS IGNORED, AND THAT THE SUBTYPE " & + "CONSTRAINT ASSOCIATED WITH THE RENAMED " & + "VARIABLE IS USED INSTEAD"); + + IF XS'FIRST /= IDENT_INT(10) OR + XS'LAST /= IDENT_INT(24) OR + XS'LENGTH /= IDENT_INT(15) THEN + FAILED("INCORRECT VALUE OF SLICE ATTRIBUTES - 1"); + END IF; + + IF XS /= "DARK AND STORMY" THEN + FAILED("INCORRECT VALUE OF RENAMING SLICE - 1"); + END IF; + + XS := IDENT_STR("STORMY AND DARK"); + + IF S /= "IT WAS A STORMY AND DARK NIGHT" THEN + FAILED("INCORRECT VALUE OF ORIGINAL STRING - 1"); + END IF; + + IF XT'FIRST /= IDENT_INT(1) OR + XT'LAST /= IDENT_INT(5) OR + XT'LENGTH /= IDENT_INT(5) THEN + FAILED("INCORRECT VALUE OF SLICE ATTRIBUTES - 2"); + END IF; + + IF XT /= "01234" THEN + FAILED("INCORRECT VALUE OF RENAMING SLICE - 2"); + END IF; + + XT := IDENT_STR("43210"); + + IF T /= "4321056789" THEN + FAILED("INCORRECT VALUE OF ORIGINAL STRING - 2"); + END IF; + + IF XG1'FIRST /= IDENT_INT(10) OR + XG1'LAST /= IDENT_INT(24) OR + XG1'LENGTH /= IDENT_INT(15) THEN + FAILED("INCORRECT VALUE OF SLICE ATTRIBUTES - G1"); + END IF; + + IF XG1 /= "DARK AND STORMY" THEN + FAILED("INCORRECT VALUE OF RENAMING SLICE - G1"); + END IF; + + XG1 := IDENT_STR("STORMY AND DARK"); + + IF DG1 /= "IT WAS A STORMY AND DARK NIGHT" THEN + FAILED("INCORRECT VALUE OF ORIGINAL STRING - G1"); + END IF; + + IF XG2'FIRST /= IDENT_INT(1) OR + XG2'LAST /= IDENT_INT(5) OR + XG2'LENGTH /= IDENT_INT(5) THEN + FAILED("INCORRECT VALUE OF SLICE ATTRIBUTES - G2"); + END IF; + + IF XG2 /= "01234" THEN + FAILED("INCORRECT VALUE OF RENAMING SLICE - G2"); + END IF; + + XG2 := IDENT_STR("43210"); + + IF DG2 /= "4321056789" THEN + FAILED("INCORRECT VALUE OF ORIGINAL STRING - G2"); + END IF; + + RESULT; + +EXCEPTION + WHEN OTHERS => + FAILED("UNEXPECTED EXCEPTION RAISED"); + RESULT; +END C85006G; diff --git a/gcc/testsuite/ada/acats/tests/c8/c85007a.ada b/gcc/testsuite/ada/acats/tests/c8/c85007a.ada new file mode 100644 index 000000000..87eda143f --- /dev/null +++ b/gcc/testsuite/ada/acats/tests/c8/c85007a.ada @@ -0,0 +1,115 @@ +-- C85007A.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 A RENAMED OUT FORMAL PARAMETER, AS +-- WELL AS THE DISCRIMINANTS OF THE RENAMED SUBCOMPONENTS OF AN OUT +-- FORMAL PARAMETER, MAY BE READ INSIDE THE PROCEDURE. + +-- SPS 02/17/84 (SEE C62006A-B.ADA) +-- EG 02/21/84 + +WITH REPORT; USE REPORT; + +PROCEDURE C85007A IS + +BEGIN + + TEST ("C85007A", "CHECK THAT THE DISCRIMINANTS OF A RENAMED 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; + + SUBTYPE R1_2 IS R1(2); + + R : R2 (5); + + PROCEDURE PROC (REC : OUT R2) IS + + REC1 : R2 RENAMES REC; + REC2 : R1_2 RENAMES REC.C; + REC3 : R2 RENAMES REC1; + REC4 : R1_2 RENAMES REC1.C; + REC5 : R1_2 RENAMES REC4; + + BEGIN + + IF REC1.D2 /= 5 THEN + FAILED ("UNABLE TO CORRECTLY READ DISCRIMINANT OF" & + " A RENAMED OUT PARAMETER"); + END IF; + + IF REC1.C.D1 /= 2 THEN + FAILED ("UNABLE TO CORRECTLY READ DISCRIMINANT " & + "OF THE SUBCOMPONENT OF A RENAMED OUT " & + "PARAMETER"); + END IF; + + IF REC2.D1 /= 2 THEN + FAILED ("UNABLE TO CORRECTLY READ DISCRIMINANT " & + "OF A RENAMED SUBCOMPONENT OF AN OUT " & + "PARAMETER"); + END IF; + + IF REC3.D2 /= 5 THEN + FAILED ("UNABLE TO CORRECTLY READ DISCRIMINANT OF" & + " A RENAME OF A RENAMED OUT PARAMETER"); + END IF; + + IF REC3.C.D1 /= 2 THEN + FAILED ("UNABLE TO CORRECTLY READ DISCRIMINANT " & + "OF THE SUBCOMPONENT OF A RENAME OF A " & + "RENAMED OUT PARAMETER"); + END IF; + + IF REC4.D1 /= 2 THEN + FAILED ("UNABLE TO CORRECTLY READ DISCRIMINANT " & + "OF A RENAMED SUBCOMPONENT OF A RENAMED" & + " OUT PARAMETER"); + END IF; + + IF REC5.D1 /= 2 THEN + FAILED ("UNABLE TO CORRECTLY READ DISCRIMINANT " & + "OF A RENAME OF RENAMED SUBCOMPONENT OF" & + " A RENAMED OUT PARAMETER"); + END IF; + + END PROC; + + BEGIN + + PROC (R); + + END; + + RESULT; + +END C85007A; diff --git a/gcc/testsuite/ada/acats/tests/c8/c85007e.ada b/gcc/testsuite/ada/acats/tests/c8/c85007e.ada new file mode 100644 index 000000000..da1f9559c --- /dev/null +++ b/gcc/testsuite/ada/acats/tests/c8/c85007e.ada @@ -0,0 +1,102 @@ +-- C85007E.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 RENAMED OUT PARAMETER, OUT PARAMETER COMPONENT, OR +-- OUT PARAMETER SLICE CAN BE ASSIGNED TO. + +-- EG 02/22/84 + +WITH REPORT; + +PROCEDURE C85007E IS + + USE REPORT; + +BEGIN + + TEST("C85007E","CHECK THAT A RENAMED OUT PARAMETER, PARAMETER " & + "COMPONENT, OR PARAMETER SLICE CAN BE ASSIGNED TO"); + + DECLARE + + TYPE AT1 IS ARRAY(1 .. 3) OF INTEGER; + TYPE RT (A : INTEGER) IS + RECORD + B : AT1; + C : INTEGER; + END RECORD; + + A1, B1 : INTEGER; + A2, B2 : AT1; + A3, B3 : RT(1); + + PROCEDURE PROC1 (A : OUT INTEGER; + B : OUT AT1; + C : OUT RT) IS + + AA : INTEGER RENAMES A; + BB : AT1 RENAMES B; + CC : RT RENAMES C; + + BEGIN + + AA := -1; + BB := (1 .. 3 => -2); + CC := (1, (2, 3, 4), 5); + + END PROC1; + + PROCEDURE PROC2 (X : OUT AT1; + Y : OUT INTEGER; + Z : OUT RT) IS + + XX : AT1 RENAMES X; + YY : INTEGER RENAMES Y; + ZZ : RT RENAMES Z; + + BEGIN + + PROC1 (YY, XX, ZZ); + + END PROC2; + + BEGIN + + PROC1 (A1, A2, A3); + IF A1 /= IDENT_INT(-1) OR A2 /= (1 .. 3 => IDENT_INT(-2)) OR + A3 /= (1, (2, 3, 4), IDENT_INT(5)) THEN + FAILED ("CASE 1 : ERROR IN ASSIGNMENT"); + END IF; + + PROC2 (B2, B1, B3); + IF B1 /= IDENT_INT(-1) OR B2 /= (1 .. 3 => IDENT_INT(-2)) OR + B3 /= (1, (2, 3, 4), IDENT_INT(5)) THEN + FAILED ("CASE 2 : ERROR IN ASSIGNMENT"); + END IF; + + END; + + RESULT; + +END C85007E; diff --git a/gcc/testsuite/ada/acats/tests/c8/c85009a.ada b/gcc/testsuite/ada/acats/tests/c8/c85009a.ada new file mode 100644 index 000000000..23d3c60d2 --- /dev/null +++ b/gcc/testsuite/ada/acats/tests/c8/c85009a.ada @@ -0,0 +1,109 @@ +-- C85009A.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 PREDEFINED AND USER-DEFINED EXCEPTIONS CAN BE RENAMED +-- AND THAT HANDLERS REFERRING TO EITHER NAME ARE INVOKED WHEN THE +-- EXCEPTION IS RAISED, EVEN BY AN EXPLICIT 'RAISE' STATEMENT +-- REFERRING TO THE OTHER NAME. + +-- HISTORY: +-- JET 03/24/88 CREATED ORIGINAL TEST. + +WITH REPORT; USE REPORT; +PROCEDURE C85009A IS + + MY_EXCEPTION : EXCEPTION; + + MY_EXCEPTION2 : EXCEPTION RENAMES MY_EXCEPTION; + + CONSTRAINT_ERROR2 : EXCEPTION RENAMES CONSTRAINT_ERROR; + + I : INTEGER := 1; + +BEGIN + TEST ("C85009A", "CHECK THAT PREDEFINED AND USER-DEFINED " & + "EXCEPTIONS CAN BE RENAMED AND THAT HANDLERS " & + "REFERRING TO EITHER NAME ARE INVOKED WHEN " & + "THE EXCEPTION IS RAISED, EVEN BY AN EXPLICIT " & + "'RAISE' STATEMENT REFERRING TO THE OTHER NAME"); + + BEGIN + RAISE MY_EXCEPTION; + FAILED ("MY_EXCEPTION NOT RAISED"); + EXCEPTION + WHEN MY_EXCEPTION2 => + NULL; + WHEN OTHERS => + FAILED ("WRONG EXCEPTION RAISED BY MY_EXCEPTION"); + END; + + BEGIN + RAISE MY_EXCEPTION2; + FAILED ("MY_EXCEPTION2 NOT RAISED"); + EXCEPTION + WHEN MY_EXCEPTION => + NULL; + WHEN OTHERS => + FAILED ("WRONG EXCEPTION RAISED BY MY_EXCEPTION2"); + END; + + DECLARE + TYPE COLORS IS (RED, BLUE, YELLOW); + E : COLORS := RED; + BEGIN + E := COLORS'PRED(E); + IF NOT EQUAL(COLORS'POS(E),COLORS'POS(E)) THEN + COMMENT("DON'T OPTIMIZE E"); + END IF; + FAILED ("CONSTRAINT_ERROR NOT RAISED BY PRED(RED)"); + EXCEPTION + WHEN CONSTRAINT_ERROR2 => + NULL; + WHEN OTHERS => + FAILED ("WRONG EXCEPTION RAISED BY PRED(RED)"); + END; + + BEGIN + RAISE CONSTRAINT_ERROR; + FAILED ("CONSTRAINT_ERROR NOT RAISED"); + EXCEPTION + WHEN CONSTRAINT_ERROR2 => + NULL; + WHEN OTHERS => + FAILED ("WRONG EXCEPTION RAISED BY CONSTRAINT_ERROR"); + END; + + BEGIN + RAISE CONSTRAINT_ERROR2; + FAILED ("CONSTRAINT_ERROR2 NOT RAISED"); + EXCEPTION + WHEN CONSTRAINT_ERROR => + NULL; + WHEN OTHERS => + FAILED ("WRONG EXCEPTION RAISED BY CONSTRAINT_ERROR2"); + END; + + RESULT; +END C85009A; diff --git a/gcc/testsuite/ada/acats/tests/c8/c85011a.ada b/gcc/testsuite/ada/acats/tests/c8/c85011a.ada new file mode 100644 index 000000000..538f9c235 --- /dev/null +++ b/gcc/testsuite/ada/acats/tests/c8/c85011a.ada @@ -0,0 +1,145 @@ +-- C85011A.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 A PACKAGE CAN BE RENAMED AND THE NEW NAME CAN APPEAR +-- IN A RENAMING DECLARATION, AND THAT A 'USE' CLAUSE CAN REFER TO +-- THE PACKAGE BY EITHER NAME, INCLUDING RENAMINGS OF GENERIC AND +-- NONGENERIC PACKAGES INSIDE THEMSELVES. + +-- HISTORY: +-- JET 04/28/88 CREATED ORIGINAL TEST. + +WITH REPORT; USE REPORT; +PROCEDURE C85011A IS + + PACKAGE PACK1 IS + I : NATURAL := 0; + PACKAGE PACKA RENAMES PACK1; + END PACK1; + + GENERIC + TYPE T IS RANGE <>; + PACKAGE GPACK IS + J : T := T'FIRST; + PACKAGE PACKB RENAMES GPACK; + END GPACK; + + PACKAGE PACK2 IS NEW GPACK(NATURAL); + + PACKAGE PACK3 RENAMES PACK1; + PACKAGE PACK4 RENAMES PACK2; + PACKAGE PACK5 RENAMES PACK3; + PACKAGE PACK6 RENAMES PACK4; + +BEGIN + TEST ("C85011A", "CHECK THAT A PACKAGE CAN BE RENAMED AND THE " & + "NEW NAME CAN APPEAR IN A RENAMING " & + "DECLARATION, AND THAT A 'USE' CLAUSE CAN " & + "REFER TO THE PACKAGE BY EITHER NAME, " & + "INCLUDING RENAMINGS OF GENERIC AND NONGENERIC " & + "PACKAGES INSIDE THEMSELVES"); + + IF PACK1.I /= IDENT_INT(0) THEN + FAILED ("INCORRECT VALUE OF PACK1.I"); + END IF; + + IF PACK2.J /= IDENT_INT(0) THEN + FAILED ("INCORRECT VALUE OF PACK2.J"); + END IF; + + IF PACK3.I /= IDENT_INT(0) THEN + FAILED ("INCORRECT VALUE OF PACK3.I"); + END IF; + + IF PACK4.J /= IDENT_INT(0) THEN + FAILED ("INCORRECT VALUE OF PACK4.J"); + END IF; + + IF PACK5.I /= IDENT_INT(0) THEN + FAILED ("INCORRECT VALUE OF PACK5.I"); + END IF; + + IF PACK6.J /= IDENT_INT(0) THEN + FAILED ("INCORRECT VALUE OF PACK6.J"); + END IF; + + IF PACK1.PACKA.I /= IDENT_INT(0) THEN + FAILED ("INCORRECT VALUE OF PACK1.PACKA.I"); + END IF; + + IF PACK2.PACKB.J /= IDENT_INT(0) THEN + FAILED ("INCORRECT VALUE OF PACK2.PACKB.J"); + END IF; + + DECLARE + USE PACK1, PACK2; + BEGIN + IF I /= IDENT_INT(0) THEN + FAILED ("INCORRECT VALUE OF I (1)"); + END IF; + + IF J /= IDENT_INT(0) THEN + FAILED ("INCORRECT VALUE OF J (1)"); + END IF; + END; + + DECLARE + USE PACK3, PACK4; + BEGIN + IF I /= IDENT_INT(0) THEN + FAILED ("INCORRECT VALUE OF I (2)"); + END IF; + + IF J /= IDENT_INT(0) THEN + FAILED ("INCORRECT VALUE OF J (2)"); + END IF; + END; + + DECLARE + USE PACK5, PACK6; + BEGIN + IF I /= IDENT_INT(0) THEN + FAILED ("INCORRECT VALUE OF I (3)"); + END IF; + + IF J /= IDENT_INT(0) THEN + FAILED ("INCORRECT VALUE OF J (3)"); + END IF; + END; + + DECLARE + USE PACK1.PACKA, PACK2.PACKB; + BEGIN + IF I /= IDENT_INT(0) THEN + FAILED ("INCORRECT VALUE OF I (4)"); + END IF; + + IF J /= IDENT_INT(0) THEN + FAILED ("INCORRECT VALUE OF J (4)"); + END IF; + END; + + RESULT; +END C85011A; diff --git a/gcc/testsuite/ada/acats/tests/c8/c85013a.ada b/gcc/testsuite/ada/acats/tests/c8/c85013a.ada new file mode 100644 index 000000000..9877760e4 --- /dev/null +++ b/gcc/testsuite/ada/acats/tests/c8/c85013a.ada @@ -0,0 +1,150 @@ +-- C85013A.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) A SUBPROGRAM OR ENTRY CAN BE RENAMED WITH: +-- A1) DIFFERENT PARAMETER NAMES; +-- A2) DIFFERENT DEFAULT VALUES; +-- A3) DIFFERENT PARAMETERS HAVING DEFAULT VALUES; +-- AND THAT THE NEW NAMES/DEFAULTS ARE USED WHEN THE NEW NAME +-- IS USED IN A CALL. + +-- B) FORMAL PARAMETER CONSTRAINTS FOR THE NEW NAME ARE IGNORED IN +-- FAVOR OF THE CONSTRAINTS ASSOCIATED WITH THE RENAMED ENTITY. + +-- EG 02/22/84 + +WITH REPORT; + +PROCEDURE C85013A IS + + USE REPORT; + +BEGIN + + TEST("C85013A","CHECK THAT A SUBPROGRAM CAN BE RENAMED AND " & + "THAT THE NEW NAMES/DEFAULTS ARE USED WITH " & + "THE CONSTRAINTS ASSOCIATED WITH THE RENAMED" & + " ENTITY"); + + DECLARE + + TYPE TA IS ARRAY(1 .. 5) OF INTEGER; + + FUNCTION PROC1 (A : INTEGER := 1; + B : TA := (1 .. 5 => 1)) RETURN INTEGER; + FUNCTION PROCA (C : INTEGER := 1; + D : TA := (1 .. 5 => 1)) RETURN INTEGER + RENAMES PROC1; + FUNCTION PROCB (B : INTEGER := 1; + A : TA := (1 .. 5 => 1)) RETURN INTEGER + RENAMES PROC1; + FUNCTION PROCC (A : INTEGER := 2; + B : TA := (1, 2, 3, 4, 5)) RETURN INTEGER + RENAMES PROC1; + FUNCTION PROCD (C : INTEGER := 2; + D : TA := (1, 2, 3, 4, 5))RETURN INTEGER + RENAMES PROC1; + + FUNCTION PROC1 (A : INTEGER := 1; + B : TA := (1 .. 5 => 1)) RETURN INTEGER IS + BEGIN + FOR I IN 1 .. 5 LOOP + IF A = B(I) THEN + RETURN I; + END IF; + END LOOP; + RETURN 0; + END PROC1; + + BEGIN + + IF PROC1 /= 1 THEN + FAILED ("CASE A : PARAMETERS NOT PROPERLY INITIALIZED"); + END IF; + IF PROC1(A => 2) /= 0 THEN + FAILED ("CASE A : INCORRECT RESULT"); + END IF; + IF PROCA /= 1 THEN + FAILED ("CASE A1 : INCORRECT RESULT (DEFAULT)"); + END IF; + IF PROCA(D => (5, 4, 3, 2, 1)) /= 5 THEN + FAILED ("CASE A1 : INCORRECT RESULT"); + END IF; + IF PROCB /= 1 THEN + FAILED ("CASE A1 : INCORRECT RESULT (DEFAULT)"); + END IF; + IF PROCB(A => (5, 4, 3, 2, 1), B => 2) /= 4 THEN + FAILED ("CASE A1 : INCORRECT RESULT "); + END IF; + IF PROCC /= 2 THEN + FAILED ("CASE A2 : INCORRECT RESULT (DEFAULT)"); + END IF; + IF PROCC(3) /= 3 THEN + FAILED ("CASE A2 : INCORRECT RESULT "); + END IF; + IF PROCD /= 2 THEN + FAILED ("CASE A2 : INCORRECT RESULT (DEFAULT)"); + END IF; + IF PROCD(4) /= 4 THEN + FAILED ("CASE A2 : INCORRECT RESULT "); + END IF; + + END; + + DECLARE + + TYPE TA IS ARRAY (INTEGER RANGE <>) OF INTEGER; + SUBTYPE STA1 IS TA(1 .. 5); + SUBTYPE STA2 IS TA(11 .. 15); + + PROCEDURE PROC1 (A : STA1; + ID : STRING); + PROCEDURE PROC2 (A : STA2; + ID : STRING) RENAMES PROC1; + + PROCEDURE PROC1 (A : STA1; + ID : STRING) IS + BEGIN + IF A'FIRST /= IDENT_INT(1) THEN + FAILED ("CASE B : INCORRECT LOWER BOUND " & + "GENERATED BY " & ID); + END IF; + IF A'LAST /= IDENT_INT(5) THEN + FAILED ("CASE B : INCORRECT UPPER BOUND " & + "GENERATED BY " & ID); + END IF; + END PROC1; + + BEGIN + + PROC1 ((1, 2, 3, 4, 5),"PROC1"); + PROC2 ((6, 7, 8, 9, 10),"PROC2"); + + END; + + RESULT; + +END C85013A; diff --git a/gcc/testsuite/ada/acats/tests/c8/c85014a.ada b/gcc/testsuite/ada/acats/tests/c8/c85014a.ada new file mode 100644 index 000000000..cd924ac80 --- /dev/null +++ b/gcc/testsuite/ada/acats/tests/c8/c85014a.ada @@ -0,0 +1,142 @@ +-- C85014A.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 THE NUMBER OF FORMAL PARAMETERS IS USED TO DETERMINE +-- WHICH SUBPROGRAM OR ENTRY IS BEING RENAMED. + +-- HISTORY: +-- JET 03/24/88 CREATED ORIGINAL TEST. +-- BCB 04/18/90 CORRECTED ERROR MESSAGE FOR ENTRY2. + +WITH REPORT; USE REPORT; +PROCEDURE C85014A IS + + TASK TYPE T1 IS + ENTRY ENTER (I1: IN OUT INTEGER); + ENTRY STOP; + END T1; + + TASK TYPE T2 IS + ENTRY ENTER (I1, I2: IN OUT INTEGER); + ENTRY STOP; + END T2; + + TASK1 : T1; + TASK2 : T2; + + FUNCTION F RETURN T1 IS + BEGIN + RETURN TASK1; + END F; + + FUNCTION F RETURN T2 IS + BEGIN + RETURN TASK2; + END F; + + PROCEDURE PROC (I1: IN OUT INTEGER) IS + BEGIN + I1 := I1 + 1; + END PROC; + + PROCEDURE PROC (I1, I2: IN OUT INTEGER) IS + BEGIN + I1 := I1 + 2; + I2 := I2 + 2; + END PROC; + + TASK BODY T1 IS + ACCEPTING_ENTRIES : BOOLEAN := TRUE; + BEGIN + WHILE ACCEPTING_ENTRIES LOOP + SELECT + ACCEPT ENTER (I1 : IN OUT INTEGER) DO + I1 := I1 + 1; + END ENTER; + OR + ACCEPT STOP DO + ACCEPTING_ENTRIES := FALSE; + END STOP; + END SELECT; + END LOOP; + END T1; + + TASK BODY T2 IS + ACCEPTING_ENTRIES : BOOLEAN := TRUE; + BEGIN + WHILE ACCEPTING_ENTRIES LOOP + SELECT + ACCEPT ENTER (I1, I2 : IN OUT INTEGER) DO + I1 := I1 + 2; + I2 := I2 + 2; + END ENTER; + OR + ACCEPT STOP DO + ACCEPTING_ENTRIES := FALSE; + END STOP; + END SELECT; + END LOOP; + END T2; + +BEGIN + TEST ("C85014A", "CHECK THAT THE NUMBER OF FORMAL PARAMETERS IS " & + "USED TO DETERMINE WHICH SUBPROGRAM OR ENTRY " & + "IS BEING RENAMED"); + + DECLARE + PROCEDURE PROC1 (J1: IN OUT INTEGER) RENAMES PROC; + PROCEDURE PROC2 (J1, J2: IN OUT INTEGER) RENAMES PROC; + + PROCEDURE ENTRY1 (J1: IN OUT INTEGER) RENAMES F.ENTER; + PROCEDURE ENTRY2 (J1, J2: IN OUT INTEGER) RENAMES F.ENTER; + + K1, K2 : INTEGER := 0; + BEGIN + PROC1(K1); + IF K1 /= IDENT_INT(1) THEN + FAILED("INCORRECT RETURN VALUE FROM PROC1"); + END IF; + + ENTRY1(K2); + IF K2 /= IDENT_INT(1) THEN + FAILED("INCORRECT RETURN VALUE FROM ENTRY1"); + END IF; + + PROC2(K1, K2); + IF K1 /= IDENT_INT(3) OR K2 /= IDENT_INT(3) THEN + FAILED("INCORRECT RETURN VALUE FROM PROC2"); + END IF; + + ENTRY2(K1, K2); + IF K1 /= IDENT_INT(5) OR K2 /= IDENT_INT(5) THEN + FAILED("INCORRECT RETURN VALUE FROM ENTRY2"); + END IF; + END; + + TASK1.STOP; + TASK2.STOP; + + RESULT; +END C85014A; diff --git a/gcc/testsuite/ada/acats/tests/c8/c85014b.ada b/gcc/testsuite/ada/acats/tests/c8/c85014b.ada new file mode 100644 index 000000000..ba195613e --- /dev/null +++ b/gcc/testsuite/ada/acats/tests/c8/c85014b.ada @@ -0,0 +1,192 @@ +-- C85014B.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 THE BASE TYPE OF THE FORMAL PARAMETER AND THE RESULT +-- TYPE ARE USED TO DETERMINE WHICH SUBPROGRAM OR ENTRY IS BEING +-- RENAMED. + +-- HISTORY: +-- JET 03/24/88 CREATED ORIGINAL TEST. + +WITH REPORT; USE REPORT; +PROCEDURE C85014B IS + + TYPE INT IS NEW INTEGER; + SUBTYPE SUBINT0 IS INT RANGE 0..INT'LAST; + SUBTYPE SUBINT1 IS INT RANGE 1..INT'LAST; + + TASK TYPE T1 IS + ENTRY ENTER (I1: IN OUT INTEGER); + ENTRY STOP; + END T1; + + TASK TYPE T2 IS + ENTRY ENTER (I1: IN OUT INT); + ENTRY STOP; + END T2; + + TASK1 : T1; + TASK2 : T2; + + FUNCTION F RETURN T1 IS + BEGIN + RETURN TASK1; + END F; + + FUNCTION F RETURN T2 IS + BEGIN + RETURN TASK2; + END F; + + PROCEDURE PROC (I1: IN OUT INTEGER) IS + BEGIN + I1 := I1 + 1; + END PROC; + + PROCEDURE PROC (I1: IN OUT INT) IS + BEGIN + I1 := I1 + 2; + END PROC; + + FUNCTION FUNK (I1: INTEGER) RETURN INTEGER IS + BEGIN + RETURN I1 + 1; + END FUNK; + + FUNCTION FUNK (I1: INTEGER) RETURN INT IS + BEGIN + RETURN INT(I1) + 2; + END FUNK; + + FUNCTION FUNKX (N : NATURAL) RETURN POSITIVE IS + BEGIN + RETURN N + 1; + END FUNKX; + + FUNCTION FUNKX (N : SUBINT0) RETURN SUBINT1 IS + BEGIN + RETURN N + 2; + END FUNKX; + + TASK BODY T1 IS + ACCEPTING_ENTRIES : BOOLEAN := TRUE; + BEGIN + WHILE ACCEPTING_ENTRIES LOOP + SELECT + ACCEPT ENTER (I1 : IN OUT INTEGER) DO + I1 := I1 + 1; + END ENTER; + OR + ACCEPT STOP DO + ACCEPTING_ENTRIES := FALSE; + END STOP; + END SELECT; + END LOOP; + END T1; + + TASK BODY T2 IS + ACCEPTING_ENTRIES : BOOLEAN := TRUE; + BEGIN + WHILE ACCEPTING_ENTRIES LOOP + SELECT + ACCEPT ENTER (I1 : IN OUT INT) DO + I1 := I1 + 2; + END ENTER; + OR + ACCEPT STOP DO + ACCEPTING_ENTRIES := FALSE; + END STOP; + END SELECT; + END LOOP; + END T2; + +BEGIN + TEST ("C85014B", "CHECK THAT THE BASE TYPE OF THE FORMAL " & + "PARAMETER AND THE RESULT TYPE ARE USED TO " & + "DETERMINE WHICH SUBPROGRAM OR ENTRY IS BEING " & + "RENAMED"); + + DECLARE + PROCEDURE PROC1 (J1: IN OUT INTEGER) RENAMES PROC; + PROCEDURE PROC2 (J1: IN OUT INT) RENAMES PROC; + + FUNCTION FUNK1 (J1: INTEGER) RETURN INTEGER RENAMES FUNK; + FUNCTION FUNK2 (J1: INTEGER) RETURN INT RENAMES FUNK; + + PROCEDURE ENTRY1 (J1: IN OUT INTEGER) RENAMES F.ENTER; + PROCEDURE ENTRY2 (J1: IN OUT INT) RENAMES F.ENTER; + + FUNCTION FUNK3 (J1: POSITIVE) RETURN NATURAL RENAMES FUNKX; + FUNCTION FUNK4 (J1: SUBINT1) RETURN SUBINT0 RENAMES FUNKX; + + K1 : INTEGER := 0; + K2 : INT := 0; + BEGIN + PROC1(K1); + IF K1 /= IDENT_INT(1) THEN + FAILED("INCORRECT RETURN VALUE FROM PROC1"); + END IF; + + K1 := FUNK1(K1); + IF K1 /= IDENT_INT(2) THEN + FAILED("INCORRECT RETURN VALUE FROM FUNK1"); + END IF; + + ENTRY1(K1); + IF K1 /= IDENT_INT(3) THEN + FAILED("INCORRECT RETURN VALUE FROM ENTRY1"); + END IF; + + K1 := FUNK3(K1); + IF K1 /= IDENT_INT(4) THEN + FAILED("INCORRECT RETURN VALUE FROM FUNK3"); + END IF; + + PROC2(K2); + IF INTEGER(K2) /= IDENT_INT(2) THEN + FAILED("INCORRECT RETURN VALUE FROM PROC2"); + END IF; + + K2 := FUNK2(INTEGER(K2)); + IF INTEGER(K2) /= IDENT_INT(4) THEN + FAILED("INCORRECT RETURN VALUE FROM FUNK2"); + END IF; + + ENTRY2(K2); + IF INTEGER(K2) /= IDENT_INT(6) THEN + FAILED("INCORRECT RETURN VALUE FROM ENTRY2"); + END IF; + + K2 := FUNK4(K2); + IF INTEGER(K2) /= IDENT_INT(8) THEN + FAILED("INCORRECT RETURN VALUE FROM FUNK4"); + END IF; + END; + + TASK1.STOP; + TASK2.STOP; + + RESULT; +END C85014B; diff --git a/gcc/testsuite/ada/acats/tests/c8/c85014c.ada b/gcc/testsuite/ada/acats/tests/c8/c85014c.ada new file mode 100644 index 000000000..6e91f8f63 --- /dev/null +++ b/gcc/testsuite/ada/acats/tests/c8/c85014c.ada @@ -0,0 +1,118 @@ +-- C85014C.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 THE PRESENCE OR ABSENCE OF A RESULT TYPE IS USED TO +-- DETERMINE WHICH SUBPROGRAM OR ENTRY IS BEING RENAMED. + +-- HISTORY: +-- JET 03/24/88 CREATED ORIGINAL TEST. + +WITH REPORT; USE REPORT; +PROCEDURE C85014C IS + + I, J : INTEGER; + + TASK TYPE T IS + ENTRY Q (I1 : INTEGER); + END T; + + TASK0 : T; + + PACKAGE FUNC IS + FUNCTION Q (I1 : INTEGER) RETURN INTEGER; + FUNCTION FUNC RETURN T; + END FUNC; + USE FUNC; + + PROCEDURE PROC (I1: INTEGER) IS + BEGIN + I := I1; + END PROC; + + FUNCTION PROC (I1: INTEGER) RETURN INTEGER IS + BEGIN + I := I1 + 1; + RETURN 0; + END PROC; + + TASK BODY T IS + BEGIN + ACCEPT Q (I1 : INTEGER) DO + I := I1; + END Q; + END T; + + PACKAGE BODY FUNC IS + FUNCTION Q (I1 : INTEGER) RETURN INTEGER IS + BEGIN + I := I1 + 1; + RETURN 0; + END Q; + + FUNCTION FUNC RETURN T IS + BEGIN + RETURN TASK0; + END FUNC; + END FUNC; + +BEGIN + TEST ("C85014C", "CHECK THAT THE PRESENCE OR ABSENCE OF A " & + "RESULT TYPE IS USED TO DETERMINE WHICH " & + "SUBPROGRAM OR ENTRY IS BEING RENAMED"); + + DECLARE + PROCEDURE PROC1 (J1: INTEGER) RENAMES PROC; + + FUNCTION PROC2 (J1: INTEGER) RETURN INTEGER RENAMES PROC; + BEGIN + PROC1(1); + IF I /= IDENT_INT(1) THEN + FAILED("INCORRECT VALUE OF I AFTER PROC1"); + END IF; + + J := PROC2(1); + IF I /= IDENT_INT(2) THEN + FAILED("INCORRECT VALUE OF I AFTER PROC2"); + END IF; + END; + + DECLARE + PROCEDURE FUNC1 (J1 : INTEGER) RENAMES FUNC.FUNC.Q; + + FUNCTION FUNC2 (J1 : INTEGER) RETURN INTEGER RENAMES FUNC.Q; + BEGIN + FUNC1(1); + IF I /= IDENT_INT(1) THEN + FAILED("INCORRECT VALUE OF I AFTER FUNC1"); + END IF; + + J := FUNC2(1); + IF I /= IDENT_INT(2) THEN + FAILED("INCORRECT VALUE OF I AFTER FUNC2"); + END IF; + END; + + RESULT; +END C85014C; diff --git a/gcc/testsuite/ada/acats/tests/c8/c85017a.ada b/gcc/testsuite/ada/acats/tests/c8/c85017a.ada new file mode 100644 index 000000000..4424a6582 --- /dev/null +++ b/gcc/testsuite/ada/acats/tests/c8/c85017a.ada @@ -0,0 +1,61 @@ +-- C85017A.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 RENAMING A PREDEFINED OPERATION WITH AN IDENTIFIER +-- AND THEN RENAMING THE IDENTIFIER AS AN OPERATOR SYMBOL ALLOWS THE +-- NEW NAME TO BE USED IN A STATIC EXPRESSION. + +-- HISTORY: +-- JET 03/24/88 CREATED ORIGINAL TEST. + +WITH REPORT; USE REPORT; +PROCEDURE C85017A IS + + FUNCTION PLUS (L,R : INTEGER) RETURN INTEGER RENAMES "+"; + FUNCTION MINUS (L,R : INTEGER) RETURN INTEGER RENAMES "-"; + + FUNCTION "-" (L,R : INTEGER) RETURN INTEGER RENAMES PLUS; + FUNCTION "+" (L,R : INTEGER) RETURN INTEGER RENAMES MINUS; + + I1 : CONSTANT INTEGER := 10 + 10; + I2 : CONSTANT INTEGER := 10 - 10; + + TYPE INT IS RANGE I1 .. I2; +BEGIN + TEST("C85017A","CHECK THAT RENAMING A PREDEFINED OPERATION WITH " & + "AN IDENTIFIER AND THEN RENAMING THE IDENTIFIER " & + "AS AN OPERATOR SYMBOL ALLOWS THE NEW NAME TO BE " & + "USED IN A STATIC EXPRESSION"); + + IF I1 /= IDENT_INT(0) THEN + FAILED ("INCORRECT VALUE OF I1: " & INTEGER'IMAGE(I1)); + END IF; + + IF I2 /= IDENT_INT(20) THEN + FAILED ("INCORRECT VALUE OF I2: " & INTEGER'IMAGE(I2)); + END IF; + + RESULT; +END C85017A; diff --git a/gcc/testsuite/ada/acats/tests/c8/c85018a.ada b/gcc/testsuite/ada/acats/tests/c8/c85018a.ada new file mode 100644 index 000000000..e82680818 --- /dev/null +++ b/gcc/testsuite/ada/acats/tests/c8/c85018a.ada @@ -0,0 +1,140 @@ +-- C85018A.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 ENTRY FAMILY MEMBER CAN BE RENAMED WITH: +-- 1) DIFFERENT PARAMETER NAMES; +-- 2) DIFFERENT DEFAULT VALUES; +-- AND THAT THE NEW NAMES/DEFAULTS ARE USED WHEN THE NEW NAME +-- IS USED IN A CALL. + +-- RJW 6/3/86 + +WITH REPORT; USE REPORT; + +PROCEDURE C85018A IS + +BEGIN + + TEST( "C85018A", "CHECK THAT AN ENTRY FAMILY MEMBER CAN BE " & + "RENAMED AND THAT THE NEW NAMES/DEFAULTS ARE " & + "THOSE ASSOCIATED WITH THE RENAMED ENTITY" ); + + DECLARE + + RESULTS : INTEGER; + + TYPE TA IS ARRAY(1 .. 5) OF INTEGER; + + TASK T IS + ENTRY ENT1 (BOOLEAN) + (A : INTEGER := 1; B : TA := (1 .. 5 => 1)); + END T; + + PROCEDURE ENTA (C : INTEGER := 1; D : TA := (1 .. 5 => 1)) + RENAMES T.ENT1 (TRUE); + + PROCEDURE ENTB (B : INTEGER := 1; A : TA := (1 .. 5 => 1)) + RENAMES T.ENT1 (TRUE); + + PROCEDURE ENTC (A : INTEGER := 2; B : TA := (1, 2, 3, 4, 5)) + RENAMES T.ENT1 (TRUE); + + PROCEDURE ENTD (C : INTEGER := 2; D : TA := (1, 2, 3, 4, 5)) + RENAMES T.ENT1 (TRUE); + + TASK BODY T IS + BEGIN + LOOP + SELECT + ACCEPT ENT1 (IDENT_BOOL (TRUE)) + (A : INTEGER := 1; + B : TA := (1 .. 5 => 1)) DO + IF A IN 1 .. 5 THEN + RESULTS := B(A); + ELSE + RESULTS := 0; + END IF; + END; + OR + TERMINATE; + END SELECT; + END LOOP; + END T; + + BEGIN + + T.ENT1 (TRUE); + IF RESULTS /= 1 THEN + FAILED ( "PARAMETERS NOT PROPERLY INITIALIZED" ); + END IF; + + T.ENT1 (TRUE) (A => 6); + IF RESULTS /= 0 THEN + FAILED ( "INCORRECT RESULTS" ); + END IF; + + ENTA; + IF RESULTS /= 1 THEN + FAILED ( "CASE 1 : INCORRECT RESULTS (DEFAULT)" ); + END IF; + + ENTA(D => (5, 4, 3, 2, 1)); + IF RESULTS /= 5 THEN + FAILED ( "CASE 1 : INCORRECT RESULTS" ); + END IF; + + ENTB; + IF RESULTS /= 1 THEN + FAILED ( "CASE 1 : INCORRECT RESULTS (DEFAULT)" ); + END IF; + + ENTB(A => (5, 4, 3, 2, 1), B => 2); + IF RESULTS /= 4 THEN + FAILED ( "CASE 1 : INCORRECT RESULTS " ); + END IF; + + ENTC; + IF RESULTS /= 2 THEN + FAILED ( "CASE 2 : INCORRECT RESULTS (DEFAULT)" ); + END IF; + + ENTC(3); + IF RESULTS /= 3 THEN + FAILED ( "CASE 2 : INCORRECT RESULTS " ); + END IF; + + ENTD; + IF RESULTS /= 2 THEN + FAILED ( "CASE 2 : INCORRECT RESULTS (DEFAULT)" ); + END IF; + + ENTD(4); + IF RESULTS /= 4 THEN + FAILED ( "CASE 2 : INCORRECT RESULTS " ); + END IF; + + END; + RESULT; + +END C85018A; diff --git a/gcc/testsuite/ada/acats/tests/c8/c85018b.ada b/gcc/testsuite/ada/acats/tests/c8/c85018b.ada new file mode 100644 index 000000000..44fbb5668 --- /dev/null +++ b/gcc/testsuite/ada/acats/tests/c8/c85018b.ada @@ -0,0 +1,288 @@ +-- C85018B.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 WHEN AN ENTRY FAMILY MEMBER IS RENAMED THE FORMAL +-- PARAMETER CONSTRAINTS FOR THE NEW NAME ARE IGNORED IN +-- FAVOR OF THE CONSTRAINTS ASSOCIATED WITH THE RENAMED ENTITY. + +-- HISTORY: +-- RJW 06/03/86 CREATED ORIGINAL TEST. +-- DHH 10/15/87 CORRECTED RANGE ERRORS. +-- GJD 11/15/95 REMOVED ADA 95 INCOMPATIBILITY (INDEX CONSTRAINT). +-- PWN 10/24/96 RESTORED CHECKS WITH ADA 95 RESULTS NOW EXPECTED. +-- PWN 12/11/96 ADJUSTED VALUES FOR ADA 95 COMPATIBILITY. +-- PWB.CTA 2/17/97 CHANGED CALL TO ENT2 TO NOT EXPECT EXCEPTION + +WITH REPORT; USE REPORT; + +PROCEDURE C85018B IS + +BEGIN + + TEST( "C85018B", "CHECK THAT WHEN AN ENTRY FAMILY MEMBER IS " & + "RENAMED THE FORMAL PARAMETER CONSTRAINTS " & + "FOR THE NEW NAME ARE IGNORED IN FAVOR OF " & + "THE CONSTRAINTS ASSOCIATED WITH THE RENAMED " & + "ENTITY" ); + + DECLARE + TYPE INT IS RANGE 1 .. 10; + SUBTYPE INT1 IS INT RANGE 1 .. 5; + SUBTYPE INT2 IS INT RANGE 6 .. 10; + + OBJ1 : INT1 := 5; + OBJ2 : INT2 := 6; + + SUBTYPE SHORTCHAR IS CHARACTER RANGE 'A' .. 'C'; + + TASK T IS + ENTRY ENT1 (SHORTCHAR) + (A : INT1; OK : BOOLEAN); + END T; + + PROCEDURE ENT2 (A : INT2; OK : BOOLEAN) + RENAMES T.ENT1 ('C'); + + TASK BODY T IS + BEGIN + LOOP + SELECT + ACCEPT ENT1 ('C') + (A : INT1; OK : BOOLEAN) DO + IF NOT OK THEN + FAILED ( "WRONG CALL EXECUTED " & + "WITH INTEGER TYPE" ); + END IF; + END; + OR + TERMINATE; + END SELECT; + END LOOP; + END T; + BEGIN + BEGIN + ENT2 (OBJ1, TRUE); + EXCEPTION + WHEN CONSTRAINT_ERROR => + FAILED ( "CONSTRAINT_ERROR RAISED WITH " & + "INTEGER TYPE" ); + WHEN OTHERS => + FAILED ( "OTHER EXCEPTION RAISED WITH " & + "INTEGER TYPE - 1" ); + END; + + BEGIN + ENT2 (OBJ2, TRUE); + EXCEPTION + WHEN CONSTRAINT_ERROR => + NULL; + WHEN OTHERS => + FAILED ( "OTHER EXCEPTION RAISED WITH " & + "INTEGER TYPE - 2" ); + END; + END; + + DECLARE + TYPE REAL IS DIGITS 3; + SUBTYPE REAL1 IS REAL RANGE -2.0 .. 0.0; + SUBTYPE REAL2 IS REAL RANGE 0.0 .. 2.0; + + OBJ1 : REAL1 := -0.25; + OBJ2 : REAL2 := 0.25; + + SUBTYPE SHORTINT IS INTEGER RANGE 9 .. 11; + + TASK T IS + ENTRY ENT1 (SHORTINT) + (A : REAL1; OK : BOOLEAN); + END T; + + PROCEDURE ENT2 (A : REAL2; OK : BOOLEAN) + RENAMES T.ENT1 (10); + + TASK BODY T IS + BEGIN + LOOP + SELECT + ACCEPT ENT1 (10) + (A : REAL1; OK : BOOLEAN) DO + IF NOT OK THEN + FAILED ( "WRONG CALL EXECUTED " & + "WITH FLOATING POINT " & + "TYPE" ); + END IF; + END; + OR + TERMINATE; + END SELECT; + END LOOP; + END T; + BEGIN + BEGIN + ENT2 (OBJ1, TRUE); + EXCEPTION + WHEN CONSTRAINT_ERROR => + FAILED ( "CONSTRAINT_ERROR RAISED WITH " & + "FLOATING POINT " & + "TYPE" ); + WHEN OTHERS => + FAILED ( "OTHER EXCEPTION RAISED WITH " & + "FLOATING POINT " & + "TYPE - 1" ); + END; + + BEGIN + ENT2 (OBJ2, FALSE); + EXCEPTION + WHEN CONSTRAINT_ERROR => + NULL; + WHEN OTHERS => + FAILED ( "OTHER EXCEPTION RAISED WITH " & + "FLOATING POINT " & + "TYPE - 2" ); + END; + END; + + DECLARE + TYPE COLOR IS (RED, YELLOW, BLUE, GREEN); + + TYPE FIXED IS DELTA 0.125 RANGE -1.0 .. 1.0; + SUBTYPE FIXED1 IS FIXED RANGE 0.0 .. 0.5; + SUBTYPE FIXED2 IS FIXED RANGE -0.5 .. 0.0; + + OBJ1 : FIXED1 := 0.125; + OBJ2 : FIXED2 := -0.125; + + TASK T IS + ENTRY ENT1 (COLOR) + (A : FIXED1; OK : BOOLEAN); + END T; + + PROCEDURE ENT2 (A : FIXED2; OK : BOOLEAN) + RENAMES T.ENT1 (BLUE); + + TASK BODY T IS + BEGIN + LOOP + SELECT + ACCEPT ENT1 (BLUE) + (A : FIXED1; OK : BOOLEAN) DO + IF NOT OK THEN + FAILED ( "WRONG CALL EXECUTED " & + "WITH FIXED POINT " & + "TYPE" ); + END IF; + END; + OR + TERMINATE; + END SELECT; + END LOOP; + END T; + BEGIN + BEGIN + ENT2 (OBJ1, TRUE); + EXCEPTION + WHEN CONSTRAINT_ERROR => + FAILED ( "CONSTRAINT_ERROR RAISED WITH " & + "FIXED POINT " & + "TYPE" ); + WHEN OTHERS => + FAILED ( "OTHER EXCEPTION RAISED WITH " & + "FIXED POINT " & + "TYPE - 1" ); + END; + + BEGIN + ENT2 (OBJ2, FALSE); + EXCEPTION + WHEN CONSTRAINT_ERROR => + NULL; + WHEN OTHERS => + FAILED ( "OTHER EXCEPTION RAISED WITH " & + "FIXED POINT " & + "TYPE - 2" ); + END; + END; + + DECLARE + TYPE TA IS ARRAY (INTEGER RANGE <>) OF INTEGER; + SUBTYPE STA1 IS TA(1 .. 5); + SUBTYPE STA2 IS TA(6 .. 10); + + OBJ1 : STA1 := (1, 2, 3, 4, 5); + OBJ2 : STA2 := (6, 7, 8, 9, 10); + + TASK T IS + ENTRY ENT1 (BOOLEAN) + (A : STA1; OK : BOOLEAN); + END T; + + PROCEDURE ENT2 (A : STA2; OK : BOOLEAN) + RENAMES T.ENT1 (FALSE); + + TASK BODY T IS + BEGIN + LOOP + SELECT + ACCEPT ENT1 (FALSE) + (A : STA1; OK : BOOLEAN) DO + IF NOT OK THEN + FAILED ( "WRONG CALL EXECUTED " & + "WITH CONSTRAINED " & + "ARRAY" ); + END IF; + END; + OR + TERMINATE; + END SELECT; + END LOOP; + END T; + BEGIN + BEGIN + ENT2 (OBJ1, TRUE); + EXCEPTION + WHEN CONSTRAINT_ERROR => + FAILED ( "CONSTRAINT_ERROR RAISED WITH " & + "CONSTRAINED ARRAY" ); + WHEN OTHERS => + FAILED ( "OTHER EXCEPTION RAISED WITH " & + "CONSTRAINED ARRAY - 1" ); + END; + + BEGIN + ENT2 (OBJ2, TRUE); + EXCEPTION + WHEN CONSTRAINT_ERROR => + FAILED ( "CONSTRAINT_ERROR RAISED WITH " & + "CONSTRAINED ARRAY" ); + WHEN OTHERS => + FAILED ( "OTHER EXCEPTION RAISED WITH " & + "CONSTRAINED ARRAY - 2" ); + END; + END; + + RESULT; + +END C85018B; diff --git a/gcc/testsuite/ada/acats/tests/c8/c85019a.ada b/gcc/testsuite/ada/acats/tests/c8/c85019a.ada new file mode 100644 index 000000000..6aec3ae67 --- /dev/null +++ b/gcc/testsuite/ada/acats/tests/c8/c85019a.ada @@ -0,0 +1,59 @@ +-- C85019A.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 CHARACTER OR OTHER ENUMERATION LITERAL MAY BE RENAMED +-- AS A FUNCTION. + +-- RJW 6/4/86 + +WITH REPORT; USE REPORT; + +PROCEDURE C85019A IS + +BEGIN + + TEST( "C85019A", "CHECK THAT A CHARACTER OR OTHER ENUMERATION " & + "LITERAL MAY BE RENAMED AS A FUNCTION" ); + + DECLARE + FUNCTION SEA RETURN CHARACTER RENAMES 'C'; + + TYPE COLOR IS (RED, YELLOW, BLUE, GREEN); + + FUNCTION TEAL RETURN COLOR RENAMES BLUE; + + BEGIN + IF SEA /= 'C' THEN + FAILED ( "SEA IS NOT EQUAL TO 'C'" ); + END IF; + + IF TEAL /= BLUE THEN + FAILED ( "TEAL IS NOT EQUAL TO BLUE" ); + END IF; + + END; + + RESULT; + +END C85019A; diff --git a/gcc/testsuite/ada/acats/tests/c8/c854001.a b/gcc/testsuite/ada/acats/tests/c8/c854001.a new file mode 100644 index 000000000..5a128ba69 --- /dev/null +++ b/gcc/testsuite/ada/acats/tests/c8/c854001.a @@ -0,0 +1,277 @@ +-- C854001.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 a subprogram declaration can be completed by a +-- subprogram renaming declaration. In particular, check that such a +-- renaming-as-body can be given in a package body to complete a +-- subprogram declared in the package specification. Check that calls +-- to the subprogram invoke the body of the renamed subprogram. Check +-- that a renaming allows a copy of an inherited or predefined subprogram +-- before overriding it later. Check that renaming a dispatching +-- operation calls the correct body in case of overriding. +-- +-- TEST DESCRIPTION: +-- This test declares a record type, an integer type, and a tagged type +-- with a set of operations in a package. A renaming of a predefined +-- equality operation of a tagged type is also defined in this package. +-- The predefined operation is overridden in the private part. In a +-- separate package, a subtype of the record type and integer type +-- are declared. Subset of the full set of operations for the record +-- and types is reexported using renamings-as-bodies. Other operations +-- are given explicit bodies. The test verifies that the appropriate +-- body is executed for each operation on the subtype. +-- +-- +-- CHANGE HISTORY: +-- 06 Dec 94 SAIC ACVC 2.0 +-- 07 Nov 95 SAIC Update and repair for ACVC 2.0.1 +-- +--! + +package C854001_0 is + + type Component is (Op_Of_Type, Op_Of_Subtype, Initial_Value); + + type Root is record + Called : Component := Op_Of_Subtype; + end record; + + procedure Root_Proc (P: in out Root); + procedure Over_Proc (P: in out Root); + + function Root_Func return Root; + function Over_Func return Root; + + type Short_Int is range 1 .. 98; + + function "+" (P1, P2 : Short_Int) return Short_Int; + function Name (P1, P2 : Short_Int) return Short_Int; + + type Tag_Type is tagged record + C : Component := Initial_Value; + end record; + -- Inherits predefined operator "=" and others. + + function Predefined_Equal (P1, P2 : Tag_Type) return Boolean + renames "="; + -- Renames predefined operator "=" before overriding. + +private + function "=" (P1, P2 : Tag_Type) + return Boolean; -- Overrides predefined operator "=". + + +end C854001_0; + + + --==================================================================-- + + +package body C854001_0 is + + procedure Root_Proc (P: in out Root) is + begin + P.Called := Initial_Value; + end Root_Proc; + + --------------------------------------- + procedure Over_Proc (P: in out Root) is + begin + P.Called := Op_Of_Type; + end Over_Proc; + + --------------------------------------- + function Root_Func return Root is + begin + return (Called => Op_Of_Type); + end Root_Func; + + --------------------------------------- + function Over_Func return Root is + begin + return (Called => Initial_Value); + end Over_Func; + + --------------------------------------- + function "+" (P1, P2 : Short_Int) return Short_Int is + begin + return 15; + end "+"; + + --------------------------------------- + function Name (P1, P2 : Short_Int) return Short_Int is + begin + return 47; + end Name; + + --------------------------------------- + function "=" (P1, P2 : Tag_Type) return Boolean is + begin + return False; + end "="; + +end C854001_0; + + --==================================================================-- + + +with C854001_0; +package C854001_1 is + + subtype Root_Subtype is C854001_0.Root; + subtype Short_Int_Subtype is C854001_0.Short_Int; + + procedure Ren_Proc (P: in out Root_Subtype); + procedure Same_Proc (P: in out Root_Subtype); + + function Ren_Func return Root_Subtype; + function Same_Func return Root_Subtype; + + function Other_Name (P1, P2 : Short_Int_Subtype) return Short_Int_Subtype; + function "-" (P1, P2 : Short_Int_Subtype) return Short_Int_Subtype; + + function User_Defined_Equal (P1, P2 : C854001_0.Tag_Type) return Boolean + renames C854001_0."="; -- Executes body of the + -- overriding declaration in + -- the private part. +end C854001_1; + + + --==================================================================-- + + +with C854001_0; +package body C854001_1 is + + -- + -- Renaming-as-body for procedure: + -- + + procedure Ren_Proc (P: in out Root_Subtype) + renames C854001_0.Root_Proc; + procedure Same_Proc (P: in out Root_Subtype) + renames C854001_0.Over_Proc; + + -- + -- Renaming-as-body for function: + -- + + function Ren_Func return Root_Subtype renames C854001_0.Root_Func; + function Same_Func return Root_Subtype renames C854001_0.Over_Func; + + function Other_Name (P1, P2 : Short_Int_Subtype) return Short_Int_Subtype + renames C854001_0."+"; + function "-" (P1, P2 : Short_Int_Subtype) return Short_Int_Subtype + renames C854001_0.Name; + +end C854001_1; + + + --==================================================================-- + +with C854001_0; +with C854001_1; -- Subtype and associated operations. +use C854001_1; + +with Report; + +procedure C854001 is + Operand1 : Root_Subtype; + Operand2 : Root_Subtype; + Operand3 : Root_Subtype; + Operand4 : Root_Subtype; + Operand5 : Short_Int_Subtype := 55; + Operand6 : Short_Int_Subtype := 46; + Operand7 : Short_Int_Subtype; + Operand8 : C854001_0.Tag_Type; -- Both Operand8 & Operand9 have + Operand9 : C854001_0.Tag_Type; -- the same default values. + + -- Direct visibility to operator symbols + use type C854001_0.Component; + use type C854001_0.Short_Int; + +begin + Report.Test ("C854001", "Check that a renaming-as-body can be given " & + "in a package body to complete a subprogram " & + "declared in the package specification. " & + "Check that calls to the subprogram invoke " & + "the body of the renamed subprogram"); + + -- + -- Only operations of the subtype are available. + -- + + Ren_Proc (Operand1); + if Operand1.Called /= C854001_0.Initial_Value then + Report.Failed ("Error calling procedure Ren_Proc"); + end if; + + --------------------------------------- + Same_Proc (Operand2); + if Operand2.Called /= C854001_0.Op_Of_Type then + Report.Failed ("Error calling procedure Same_Proc"); + end if; + + --------------------------------------- + Operand3 := Ren_Func; + if Operand3.Called /= C854001_0.Op_Of_Type then + Report.Failed ("Error calling function Ren_Func"); + end if; + + --------------------------------------- + Operand4 := Same_Func; + if Operand4.Called /= C854001_0.Initial_Value then + Report.Failed ("Error calling function Same_Func"); + end if; + + --------------------------------------- + Operand7 := C854001_1."-" (Operand5, Operand6); + if Operand7 /= 47 then + Report.Failed ("Error calling function & ""-"""); + end if; + + --------------------------------------- + Operand7 := Other_Name (Operand5, Operand6); + if Operand7 /= 15 then + Report.Failed ("Error calling function Other_Name"); + end if; + + --------------------------------------- + -- Executes body of the overriding declaration in the private part + -- of C854001_0. + if User_Defined_Equal (Operand8, Operand9) then + Report.Failed ("Error calling function User_Defined_Equal"); + end if; + + --------------------------------------- + -- Executes predefined operation. + if not C854001_0.Predefined_Equal (Operand8, Operand9) then + Report.Failed ("Error calling function Predefined_Equal"); + end if; + + Report.Result; + +end C854001; diff --git a/gcc/testsuite/ada/acats/tests/c8/c854002.a b/gcc/testsuite/ada/acats/tests/c8/c854002.a new file mode 100644 index 000000000..19bca3598 --- /dev/null +++ b/gcc/testsuite/ada/acats/tests/c8/c854002.a @@ -0,0 +1,185 @@ +-- C854002.A +-- +-- Grant of Unlimited Rights +-- +-- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687 and +-- F08630-91-C-0015, 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 WHATSOVER, 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 the requirements of the new 8.5.4(8.A) from Technical +-- Corrigendum 1 (originally discussed as AI95-00064). +-- This paragraph requires an elaboration check on renamings-as-body: +-- even if the body of the ultimately-called subprogram has been +-- elaborated, the check should fail if the renaming-as-body +-- itself has not yet been elaborated. +-- +-- TEST DESCRIPTION +-- We declare two functions F and G, and ensure that they are +-- elaborated before anything else, by using pragma Pure. Then we +-- declare two renamings-as-body: the renaming of F is direct, and +-- the renaming of G is via an access-to-function object. We call +-- the renamings during elaboration, and check that they raise +-- Program_Error. We then call them again after elaboration; this +-- time, they should work. +-- +-- CHANGE HISTORY: +-- 29 JUN 1999 RAD Initial Version +-- 23 SEP 1999 RLB Improved comments, renamed, issued. +-- 28 JUN 2002 RLB Added pragma Elaborate_All for Report. +--! + +package C854002_1 is + pragma Pure; + -- Empty. +end C854002_1; + +package C854002_1.Pure is + pragma Pure; + function F return String; + function G return String; +end C854002_1.Pure; + +with C854002_1.Pure; +package C854002_1.Renamings is + + F_Result: constant String := C854002_1.Pure.F; -- Make sure we can call F. + function Renamed_F return String; + + G_Result: constant String := C854002_1.Pure.G; + type String_Function is access function return String; + G_Pointer: String_Function := null; + -- Will be set to C854002_1.Pure.G'Access in the body. + function Renamed_G return String; + +end C854002_1.Renamings; + +package C854002_1.Caller is + + -- These procedures call the renamings; when called during elaboration, + -- we pass Should_Fail => True, which checks that Program_Error is + -- raised. Later, we use Should_Fail => False. + + procedure Call_Renamed_F(Should_Fail: Boolean); + procedure Call_Renamed_G(Should_Fail: Boolean); + +end C854002_1.Caller; + +with Report; use Report; pragma Elaborate_All (Report); +with C854002_1.Renamings; +package body C854002_1.Caller is + + Some_Error: exception; + + procedure Call_Renamed_F(Should_Fail: Boolean) is + begin + if Should_Fail then + begin + Failed(C854002_1.Renamings.Renamed_F); + raise Some_Error; + -- This raise statement is necessary, because the + -- Report package has a bug -- if Failed is called + -- before Test, then the failure is ignored, and the + -- test prints "PASSED". + -- Presumably, this raise statement will cause the + -- program to crash, thus avoiding the PASSED message. + exception + when Program_Error => + Comment("Program_Error -- OK"); + end; + else + if C854002_1.Renamings.F_Result /= C854002_1.Renamings.Renamed_F then + Failed("Bad result from renamed F"); + end if; + end if; + end Call_Renamed_F; + + procedure Call_Renamed_G(Should_Fail: Boolean) is + begin + if Should_Fail then + begin + Failed(C854002_1.Renamings.Renamed_G); + raise Some_Error; + exception + when Program_Error => + Comment("Program_Error -- OK"); + end; + else + if C854002_1.Renamings.G_Result /= C854002_1.Renamings.Renamed_G then + Failed("Bad result from renamed G"); + end if; + end if; + end Call_Renamed_G; + +begin + -- At this point, the bodies of Renamed_F and Renamed_G have not yet + -- been elaborated, so calling them should raise Program_Error: + Call_Renamed_F(Should_Fail => True); + Call_Renamed_G(Should_Fail => True); +end C854002_1.Caller; + +package body C854002_1.Pure is + + function F return String is + begin + return "This is function F"; + end F; + + function G return String is + begin + return "This is function G"; + end G; + +end C854002_1.Pure; + +with C854002_1.Pure; +with C854002_1.Caller; pragma Elaborate(C854002_1.Caller); + -- This pragma ensures that this package body (Renamings) + -- will be elaborated after Caller, so that when Caller calls + -- the renamings during its elaboration, the renamings will + -- not have been elaborated (although what the rename have been). +package body C854002_1.Renamings is + + function Renamed_F return String renames C854002_1.Pure.F; + + package Dummy is end; -- So we can insert statements here. + package body Dummy is + begin + G_Pointer := C854002_1.Pure.G'Access; + end Dummy; + + function Renamed_G return String renames G_Pointer.all; + +end C854002_1.Renamings; + +with Report; use Report; +with C854002_1.Caller; +procedure C854002 is +begin + Test("C854002", + "An elaboration check is performed for a call to a subprogram" + & " whose body is given as a renaming-as-body"); + + -- By the time we get here, all library units have been elaborated, + -- so the following calls should not raise Program_Error: + C854002_1.Caller.Call_Renamed_F(Should_Fail => False); + C854002_1.Caller.Call_Renamed_G(Should_Fail => False); + + Result; +end C854002; diff --git a/gcc/testsuite/ada/acats/tests/c8/c854003.a b/gcc/testsuite/ada/acats/tests/c8/c854003.a new file mode 100644 index 000000000..9ab2364a9 --- /dev/null +++ b/gcc/testsuite/ada/acats/tests/c8/c854003.a @@ -0,0 +1,64 @@ +-- C854003.A +-- +-- Grant of Unlimited Rights +-- +-- The Ada Conformity Assessment Authority (ACAA) holds unlimited +-- rights in the software and documentation contained herein. Unlimited +-- rights are the same as those granted by the U.S. Government for older +-- parts of the Ada Conformity Assessment Test Suite, and are defined +-- in DFAR 252.227-7013(a)(19). By making this public release, the ACAA +-- intends to confer upon all recipients unlimited rights equal to those +-- held by the ACAA. 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 a renaming-as-body used before the subprogram is frozen only +-- requires mode conformance. (Defect Report 8652/0028, as reflected in +-- Technical Corrigendum 1, RM95 8.5.4(5/1)). +-- +-- CHANGE HISTORY: +-- 29 JAN 2001 PHL Initial version. +-- 5 DEC 2001 RLB Reformatted for ACATS. +-- +--! +with Report; +use Report; +procedure C854003 is + + package P is + type T is private; + C1 : constant T; + C2 : constant T; + private + type T is new Integer'Base; + C1 : constant T := T (Ident_Int (1)); + C2 : constant T := T (Ident_Int (1)); + end P; + + function Equals (X, Y : P.T) return Boolean; + function Equals (X, Y : P.T) return Boolean renames P."="; + +begin + Test ("C854003", + "Check that a renaming-as-body used before the subprogram " & + "is frozen only requires mode conformance"); + + if not Equals (P.C1, P.C2) then + Failed ("Equality returned an unexpected result"); + end if; + + Result; +end C854003; + diff --git a/gcc/testsuite/ada/acats/tests/c8/c86003a.ada b/gcc/testsuite/ada/acats/tests/c8/c86003a.ada new file mode 100644 index 000000000..92b36638e --- /dev/null +++ b/gcc/testsuite/ada/acats/tests/c8/c86003a.ada @@ -0,0 +1,122 @@ +-- C86003A.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 'STANDARD' IS NOT TREATED AS A RESERVED WORD IN +-- SELECTED COMPONENT NAMES. + +-- RM 01/21/80 +-- EG 10/29/85 ELIMINATE THE USE OF NUMERIC_ERROR IN TEST. +-- RLB 06/29/01 CORRECTED TO ALLOW AGGRESSIVE OPTIMIZATION. + +WITH REPORT ; +PROCEDURE C86003A IS + + USE REPORT ; + +BEGIN + + TEST("C86003A" , "CHECK THAT 'STANDARD' IS NOT TREATED AS A" & + " RESERVED WORD IN SELECTED COMPONENT NAMES" ); + + DECLARE -- A + BEGIN + + DECLARE + + PACKAGE STANDARD IS + CHARACTER : BOOLEAN ; + TYPE INTEGER IS (FALSE, TRUE) ; + CONSTRAINT_ERROR : EXCEPTION ; + END STANDARD ; + + TYPE REC2 IS + RECORD + AA , BB : BOOLEAN := FALSE ; + END RECORD; + + TYPE REC1 IS + RECORD + STANDARD : REC2 ; + END RECORD; + + A : REC1 ; + TYPE ASI IS ACCESS STANDARD.INTEGER ; + VASI : ASI ; + VI : INTEGER RANGE 1 .. 10; -- THE "REAL" STANDARD + -- TYPE 'INTEGER' + + BEGIN + + VASI := NEW STANDARD.INTEGER'(STANDARD.FALSE); + STANDARD.CHARACTER := A.STANDARD.BB ; + + IF STANDARD.CHARACTER THEN FAILED( "RES. (VAR.)" ); + END IF; + + VI := IDENT_INT(11); -- TO CAUSE THE "REAL" + -- (PREDEFINED) CONSTRAINT_ERROR + -- EXCEPTION. + IF VI /= IDENT_INT(11) THEN + FAILED ("WRONG VALUE - V1"); + ELSE + FAILED ("OUT OF RANGE VALUE - V1"); + END IF; + EXCEPTION + + WHEN STANDARD.CONSTRAINT_ERROR => FAILED ("RES. (EXC.)"); + + WHEN CONSTRAINT_ERROR => NULL; + + WHEN OTHERS => FAILED ("WRONG EXCEPTION RAISED - A"); + + END ; + + EXCEPTION + + WHEN OTHERS => FAILED( "EXCEPTION RAISED BY DECL. (A)" ); + + END ; -- A + + + DECLARE -- B + + TYPE REC IS + RECORD + INTEGER : BOOLEAN := FALSE ; + END RECORD; + + STANDARD : REC ; + + BEGIN + + IF STANDARD.INTEGER THEN FAILED( "RESERVED - REC.,INT."); + END IF; + + END ; -- B + + + RESULT ; + + +END C86003A ; diff --git a/gcc/testsuite/ada/acats/tests/c8/c86004a.ada b/gcc/testsuite/ada/acats/tests/c8/c86004a.ada new file mode 100644 index 000000000..937e5f3fb --- /dev/null +++ b/gcc/testsuite/ada/acats/tests/c8/c86004a.ada @@ -0,0 +1,100 @@ +-- C86004A.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 IF A LIBRARY SUBPROGRAM DECLARATION IS PRECEDED BY A +-- "WITH" CLAUSE FOR A GENERIC LIBRARY PROCEDURE M, THEN IN THE +-- BODY OF THE SUBPROGRAM, "STANDARD.M" IS A LEGAL NAME +-- FOR THE GENERIC PROCEDURE. + +-- HISTORY: +-- DHH 03/14/88 CREATED ORIGINAL TEST. + +-- BEGIN BUILDING LIBRARY PROCEDURES + +GENERIC + TYPE ITEM IS (<>); +PROCEDURE C86004A_SWAP(X,Y: IN OUT ITEM); + +PROCEDURE C86004A_SWAP(X,Y: IN OUT ITEM) IS + T : ITEM; +BEGIN + T := X; + X := Y; + Y := T; +END C86004A_SWAP; + +WITH C86004A_SWAP; WITH REPORT; USE REPORT; +PROCEDURE C86004A1 IS + SUBTYPE INT IS INTEGER RANGE 0 .. 10; + A : INT := IDENT_INT(10); + B : INT := IDENT_INT(0); + PROCEDURE SWITCH IS NEW STANDARD.C86004A_SWAP(INT); +BEGIN + SWITCH(A,B); + + IF A /= IDENT_INT(0) THEN + FAILED("STANDARD.GENERIC PROCEDURE - 1"); + END IF; + + IF B /= IDENT_INT(10) THEN + FAILED("STANDARD.GENERIC PROCEDURE - 2"); + END IF; +END C86004A1; + +WITH C86004A_SWAP; WITH REPORT; USE REPORT; +PROCEDURE C86004A2; + +PROCEDURE C86004A2 IS + SUBTYPE INT IS INTEGER RANGE 0 .. 10; + A : INT := IDENT_INT(10); + B : INT := IDENT_INT(0); +BEGIN + DECLARE + PROCEDURE SWITCH IS NEW STANDARD.C86004A_SWAP(INT); + BEGIN + SWITCH(A,B); + END; + IF A /= IDENT_INT(0) THEN + FAILED("STANDARD.GENERIC PROCEDURE - B-0"); + END IF; + IF B /= IDENT_INT(10) THEN + FAILED("STANDARD.GENERIC PROCEDURE - B-10"); + END IF; +END C86004A2; + +WITH C86004A1; WITH C86004A2; +WITH REPORT; USE REPORT; +PROCEDURE C86004A IS +BEGIN + TEST("C86004A", "CHECK THAT IF A LIBRARY SUBPROGRAM DECLARATION " & + "IS PRECEDED BY A ""WITH"" CLAUSE FOR A GENERIC " & + "LIBRARY PROCEDURE M, THEN IN THE BODY OF THE " & + "SUBPROGRAM, ""STANDARD.M"" IS A " & + "LEGAL NAME FOR THE GENERIC PROCEDURE"); + C86004A1; + C86004A2; + + RESULT; +END C86004A; diff --git a/gcc/testsuite/ada/acats/tests/c8/c86004b0.ada b/gcc/testsuite/ada/acats/tests/c8/c86004b0.ada new file mode 100644 index 000000000..5b9d7c533 --- /dev/null +++ b/gcc/testsuite/ada/acats/tests/c8/c86004b0.ada @@ -0,0 +1,44 @@ +-- C86004B0.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: +-- INDEPENDENT FUNCTION AND SUBPROGRAM SPECIFICATION FOR C86004B +-- TEST. + +-- HISTORY: +-- DHH 08/15/88 CREATED ORIGINAL TEST. + +WITH REPORT; USE REPORT; +FUNCTION C86004B0(X : INTEGER) RETURN INTEGER IS +BEGIN + IF EQUAL(3,3) THEN + RETURN X; + ELSE + RETURN 0; + END IF; +END C86004B0; + +WITH C86004B0; +WITH REPORT; USE REPORT; -- SPEC +PROCEDURE C86004B1(INTGR : INTEGER := STANDARD.C86004B0(4)); diff --git a/gcc/testsuite/ada/acats/tests/c8/c86004b1.ada b/gcc/testsuite/ada/acats/tests/c8/c86004b1.ada new file mode 100644 index 000000000..09ae4faf6 --- /dev/null +++ b/gcc/testsuite/ada/acats/tests/c8/c86004b1.ada @@ -0,0 +1,53 @@ +-- C86004B1.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: +-- LIBRARY SUBPROGRAM BODY FOR C86004B TEST. + +-- HISTORY: +-- DHH 08/15/88 CREATED ORIGINAL TEST. + +PROCEDURE C86004B1(INTGR : INTEGER := STANDARD.C86004B0(4)) IS + + SUBTYPE INT IS INTEGER RANGE 0 .. 10; + A : INT := STANDARD.C86004B0(10); + B : INT := STANDARD.C86004B0(INTGR); + +BEGIN + TEST("C86004B", "CHECK THAT IF THE SPECIFICATION OF A LIBRARY " & + "SUBPROGRAM HAS A ""WITH"" CLAUSE FOR A LIBRARY " & + "SUBPROGRAM M, THEN IN THE FORMAL PART AND IN " & + "THE BODY (IN ANOTHER FILE), ""STANDARD.M"" IS " & + "A LEGAL NAME FOR THE SUBPROGRAM M"); + + IF B /= STANDARD.C86004B0(0) THEN + FAILED("STANDARD.SUBPROGRAM - B"); + END IF; + + IF A /= STANDARD.C86004B0(10) THEN + FAILED("STANDARD.SUBPROGRAM - A"); + END IF; + + RESULT; +END C86004B1; diff --git a/gcc/testsuite/ada/acats/tests/c8/c86004b2.ada b/gcc/testsuite/ada/acats/tests/c8/c86004b2.ada new file mode 100644 index 000000000..cb9cd23a0 --- /dev/null +++ b/gcc/testsuite/ada/acats/tests/c8/c86004b2.ada @@ -0,0 +1,46 @@ +-- C86004B2M.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 IF THE SPECIFICATION OF A LIBRARY SUBPROGRAM HAS A +-- "WITH" CLAUSE FOR A LIBRARY SUBPROGRAM M, THEN IN THE FORMAL PART +-- AND IN THE BODY (IN ANOTHER FILE), "STANDARD.M" IS A LEGAL NAME +-- FOR THE SUBPROGRAM M. + +-- SEPARATE FILES ARE: +-- C86004B0 A LIBRARY FUNCTION AND A LIBRARY SUBPROGRAM +-- SPECIFICATION. +-- C86004B1 A LIBRARY SUBPROGRAM BODY FOR THE C86004B0 +-- SPECIFICATION. +-- C86004B2M MAIN PROCEDURE USING THE SUBPROGRAM OF C86004B1. + +-- HISTORY: +-- DHH 08/15/88 CREATED ORIGINAL TEST. + +WITH C86004B1; +WITH REPORT; USE REPORT; +PROCEDURE C86004B2M IS +BEGIN + C86004B1(IDENT_INT(0)); +END C86004B2M; diff --git a/gcc/testsuite/ada/acats/tests/c8/c86004c0.ada b/gcc/testsuite/ada/acats/tests/c8/c86004c0.ada new file mode 100644 index 000000000..f3a1b3e71 --- /dev/null +++ b/gcc/testsuite/ada/acats/tests/c8/c86004c0.ada @@ -0,0 +1,60 @@ +-- C86004C0.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: +-- INDEPENDENT GENERIC FUNCTION AND SUBPROGRAM FOR C86004C TEST. + +-- HISTORY: +-- DHH 09/14/88 CREATED ORIGINAL TEST. + +WITH REPORT; USE REPORT; +GENERIC +FUNCTION C86004C0_GEN(X : INTEGER) RETURN INTEGER; + +FUNCTION C86004C0_GEN(X : INTEGER) RETURN INTEGER IS +BEGIN + IF EQUAL(3,3) THEN + RETURN X; + ELSE + RETURN 0; + END IF; +END C86004C0_GEN; + +WITH C86004C0_GEN; +PRAGMA ELABORATE(C86004C0_GEN); +FUNCTION C86004C0 IS NEW C86004C0_GEN; + +WITH C86004C0; +WITH REPORT; USE REPORT; +PROCEDURE C86004C01(INTGR : INTEGER := STANDARD.C86004C0(4)) IS + + SUBTYPE INT IS INTEGER RANGE 0 .. 10; + A : INT := STANDARD.C86004C0(10); + B : INT := STANDARD.C86004C0(INTGR); + + PROCEDURE C86004C1 IS SEPARATE; + +BEGIN + C86004C1; +END; diff --git a/gcc/testsuite/ada/acats/tests/c8/c86004c1.ada b/gcc/testsuite/ada/acats/tests/c8/c86004c1.ada new file mode 100644 index 000000000..b896a8e26 --- /dev/null +++ b/gcc/testsuite/ada/acats/tests/c8/c86004c1.ada @@ -0,0 +1,50 @@ +-- C86004C1.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: +-- SUBUNIT FOR THE C86004C01 PARENT. + +-- HISTORY: +-- DHH 09/14/88 CREATED ORIGINAL TEST. + +SEPARATE (C86004C01) +PROCEDURE C86004C1 IS +BEGIN + TEST("C86004C", "CHECK THAT IF THE SPECIFICATION OF A " & + "SUBPROGRAM HAS A ""WITH"" CLAUSE FOR A GENERIC " & + "SUBPROGRAM INSTANTIANTION M, THEN IN THE " & + "FORMAL PART AND IN THE BODY (A SUBUNIT IN " & + "ANOTHER FILE), ""STANDARD.M"" IS " & + "A LEGAL NAME FOR THE SUBPROGRAM M"); + + IF B /= STANDARD.C86004C0(0) THEN + FAILED("STANDARD.SUBPROGRAM - B"); + END IF; + + IF A /= STANDARD.C86004C0(10) THEN + FAILED("STANDARD.SUBPROGRAM - A"); + END IF; + + RESULT; +END C86004C1; diff --git a/gcc/testsuite/ada/acats/tests/c8/c86004c2.ada b/gcc/testsuite/ada/acats/tests/c8/c86004c2.ada new file mode 100644 index 000000000..ffe1e0592 --- /dev/null +++ b/gcc/testsuite/ada/acats/tests/c8/c86004c2.ada @@ -0,0 +1,45 @@ +-- C86004C2M.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 IF THE SPECIFICATION OF A LIBRARY SUBPROGRAM HAS A +-- "WITH" CLAUSE FOR A GENERIC SUBPROGRAM INSTANTIATION M, THEN IN +-- THE FORMAL PART AND IN THE BODY (A SUBUNIT IN ANOTHER FILE), +-- "STANDARD.M" IS A LEGAL NAME FOR THE SUBPROGRAM M. + +-- SEPARATE FILES ARE: +-- C86004C0 A GENERIC LIBRARY FUNCTION AND A LIBRARY SUBPROGRAM +-- DECLARING A SEPARATE SUBUNIT. +-- C86004C1 A SUBUNIT FOR THE C86004C0 PARENT. +-- C86004C2M MAIN PROCEDURE USING THE SUBPROGRAM OF C86004C0. + +-- HISTORY: +-- DHH 09/14/88 CREATED ORIGINAL TEST. + +WITH C86004C01; +WITH REPORT; USE REPORT; +PROCEDURE C86004C2M IS +BEGIN + C86004C01(IDENT_INT(0)); +END C86004C2M; diff --git a/gcc/testsuite/ada/acats/tests/c8/c86006i.ada b/gcc/testsuite/ada/acats/tests/c8/c86006i.ada new file mode 100644 index 000000000..38778f97c --- /dev/null +++ b/gcc/testsuite/ada/acats/tests/c8/c86006i.ada @@ -0,0 +1,103 @@ +-- C86006I.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 THE IDENTIFIERS "BOOLEAN, TRUE, AND FALSE" AND THE +-- IDENTIFIERS "INTEGER, NATURAL, AND POSITIVE" ARE DECLARED IN +-- THE PACKAGE "STANDARD", ALONG WITH THE OPERATORS OF THE TYPE +-- BOOLEAN AND THE TYPE INTEGER. + +-- HISTORY: +-- DTN 04/15/92 CONSOLIDATION OF C86006A AND C86006B. + +WITH REPORT; USE REPORT; +PROCEDURE C86006I IS + + ABOOL, BBOOL : STANDARD.BOOLEAN := STANDARD.FALSE; + CBOOL : STANDARD.BOOLEAN := STANDARD.TRUE; + INT1 : STANDARD.INTEGER := -2; + NAT1 : STANDARD.NATURAL := 0; + POS1, POS2 : STANDARD.POSITIVE := 2; + +BEGIN + + TEST("C86006I", "CHECK THAT THE IDENTIFIERS ""BOOLEAN, TRUE, AND " & + "FALSE"" AND THE IDENTIFIERS ""INTEGER, NATURAL, " & + "AND POSITIVE"" ARE DECLARED IN THE PACKAGE " & + """STANDARD"", ALONG WITH THE OPERATORS OF THE " & + "TYPE BOOLEAN AND THE TYPE INTEGER"); + + -- STANDARD.">" OPERATOR. + + IF STANDARD.">"(ABOOL,BBOOL) THEN + FAILED("STANDARD.> FAILED FOR BOOLEAN TYPE"); + END IF; + + IF STANDARD.">"(INT1,NAT1) THEN + FAILED("STANDARD.> FAILED FOR INTEGER-NATURAL TYPE"); + END IF; + + -- STANDARD."/=" OPERATOR. + + IF STANDARD."/="(ABOOL,BBOOL) THEN + FAILED("STANDARD./= FAILED FOR BOOLEAN TYPE"); + END IF; + + IF STANDARD."/="(POS1,POS2) THEN + FAILED("STANDARD./= FAILED FOR INTEGER-POSITIVE TYPE"); + END IF; + + -- STANDARD."AND" OPERATOR. + + IF STANDARD."AND"(CBOOL,ABOOL) THEN + FAILED("STANDARD.AND FAILED"); + END IF; + + -- STANDARD."-" BINARY OPERATOR. + + IF STANDARD."-"(INT1,POS1) /= IDENT_INT(-4) THEN + FAILED("STANDARD.- FAILED"); + END IF; + + -- STANDARD."-" UNARY OPERATOR. + + IF STANDARD."-"(INT1) /= IDENT_INT(2) THEN + FAILED("STANDARD.UNARY - FAILED"); + END IF; + + -- STANDARD."REM" OPERATOR. + + IF STANDARD."REM"(IDENT_INT(14),IDENT_INT(5)) /= IDENT_INT(4) THEN + FAILED("STANDARD.REM (++=+) FAILED"); + END IF; + + -- STANDARD."MOD" OPERATOR. + + IF STANDARD."MOD"(IDENT_INT(14),IDENT_INT(-5)) /= IDENT_INT(-1) THEN + FAILED("STANDARD.MOD (+-=-) FAILED"); + END IF; + + RESULT; + +END C86006I; diff --git a/gcc/testsuite/ada/acats/tests/c8/c86007a.ada b/gcc/testsuite/ada/acats/tests/c8/c86007a.ada new file mode 100644 index 000000000..ba41e176c --- /dev/null +++ b/gcc/testsuite/ada/acats/tests/c8/c86007a.ada @@ -0,0 +1,79 @@ +-- C86007A.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 AN EXPANDED NAME FOR AN ENTITY DECLARED IN THE VISIBLE +-- PART OF A LIBRARY PACKAGE CAN START WITH THE NAME "STANDARD". + +-- HISTORY: +-- DHH 03/15/88 CREATED ORIGINAL TEST. +-- RJW 10/26/89 ADDED "PRAGMA ELABORATE (REPORT);" + +WITH REPORT; USE REPORT; +PRAGMA ELABORATE (REPORT); +PACKAGE C86007A_PACK IS + SUBTYPE ITEM IS INTEGER RANGE 0 .. 10; + Y : STANDARD.C86007A_PACK.ITEM := IDENT_INT(5); + TYPE ACC IS ACCESS STANDARD.C86007A_PACK.ITEM; + PROCEDURE SWAP(X,Y: IN OUT ITEM); + PROCEDURE PROC; +END C86007A_PACK; + +PACKAGE BODY C86007A_PACK IS + PROCEDURE SWAP(X,Y: IN OUT STANDARD.C86007A_PACK.ITEM) IS + T : STANDARD.C86007A_PACK.ITEM; + BEGIN + T := X; + X := Y; + Y := T; + END SWAP; + + PROCEDURE PROC IS + X : STANDARD.C86007A_PACK.ITEM := IDENT_INT(10); + W : STANDARD.C86007A_PACK.ACC; + BEGIN + + W := NEW STANDARD.C86007A_PACK.ITEM; + W.ALL := X; + STANDARD.C86007A_PACK.SWAP(X, STANDARD.C86007A_PACK.Y); + IF STANDARD.C86007A_PACK.Y /= IDENT_INT(10) THEN + FAILED("FAILED STANDARD.NAME CALL PROCEDURE - B-10"); + END IF; + IF X /= IDENT_INT(5) THEN + FAILED("FAILED STANDARD.NAME CALL PROCEDURE - B-5"); + END IF; + END PROC; +END C86007A_PACK; + +WITH C86007A_PACK; WITH REPORT; USE REPORT; +PROCEDURE C86007A IS +BEGIN + TEST("C86007A", "CHECK THAT AN EXPANDED NAME FOR AN ENTITY " & + "DECLARED IN THE VISIBLE PART OF A LIBRARY " & + "PACKAGE CAN START WITH THE NAME ""STANDARD"""); + + STANDARD.C86007A_PACK.PROC; + + RESULT; +END C86007A; diff --git a/gcc/testsuite/ada/acats/tests/c8/c87a05a.ada b/gcc/testsuite/ada/acats/tests/c8/c87a05a.ada new file mode 100644 index 000000000..8efbbdeec --- /dev/null +++ b/gcc/testsuite/ada/acats/tests/c8/c87a05a.ada @@ -0,0 +1,108 @@ +-- C87A05A.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 FUNCTION CALLS AND INDEXED COMPONENT EXPRESSIONS CAN BE +-- DISTINGUISHED BY THE RULES OF OVERLOADING RESOLUTION. +-- +-- PART 1 : CORRECT RESOLUTION IS INDEXED COMPONENT EXPRESSION + +-- TRH 13 JULY 82 +-- DSJ 09 JUNE 83 + +WITH REPORT; USE REPORT; + +PROCEDURE C87A05A IS + + OK : BOOLEAN := TRUE; + TYPE VECTOR IS ARRAY (1 .. 5) OF BOOLEAN; + + PROCEDURE P (ARG : BOOLEAN) IS -- THIS IS CORRECT P + BEGIN + OK := ARG; + END P; + + PROCEDURE P (ARG : CHARACTER) IS + BEGIN + OK := FALSE; + END P; + + FUNCTION Y RETURN VECTOR IS -- THIS IS CORRECT Y + BEGIN + RETURN (VECTOR'RANGE => TRUE); + END Y; + + FUNCTION Y (ARG : INTEGER) RETURN FLOAT IS + BEGIN + OK := FALSE; + RETURN 0.0; + END Y; + + FUNCTION Y (ARG : CHARACTER) RETURN CHARACTER IS + BEGIN + OK := FALSE; + RETURN 'A'; + END Y; + + FUNCTION Y (ARG : FLOAT) RETURN FLOAT IS + BEGIN + OK := FALSE; + RETURN 0.0; + END Y; + + FUNCTION Y RETURN BOOLEAN IS + BEGIN + OK := FALSE; + RETURN FALSE; + END Y; + + FUNCTION Y (ARG : CHARACTER := 'A') RETURN BOOLEAN IS + BEGIN + OK := FALSE; + RETURN FALSE; + END Y; + + FUNCTION Z RETURN INTEGER IS -- THIS IS CORRECT Z + BEGIN + RETURN 3; + END Z; + + FUNCTION Z RETURN FLOAT IS + BEGIN + OK := FALSE; + RETURN 3.0; + END Z; + +BEGIN + TEST ("C87A05A","OVERLOADING RESOLUTION FOR DISTINGUISHING " & + "FUNCTION CALLS FROM INDEXED COMPONENTS WHERE INDEXED " & + "COMPONENTS ARE CORRECT"); + + P (Y (Z) ); + + IF NOT OK THEN + FAILED ("RESOLUTION INCORRECT"); + END IF; + + RESULT; +END C87A05A; diff --git a/gcc/testsuite/ada/acats/tests/c8/c87a05b.ada b/gcc/testsuite/ada/acats/tests/c8/c87a05b.ada new file mode 100644 index 000000000..7d99c9578 --- /dev/null +++ b/gcc/testsuite/ada/acats/tests/c8/c87a05b.ada @@ -0,0 +1,107 @@ +-- C87A05B.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 FUNCTION CALLS AND INDEXED COMPONENT EXPRESSIONS CAN BE +-- DISTINGUISHED BY THE RULES OF OVERLOADING RESOLUTION. +-- +-- PART 2 : CORRECT RESOLUTION IS FUNCTION CALL + +-- TRH 15 JULY 82 +-- DSJ 09 JUNE 83 + +WITH REPORT; USE REPORT; + +PROCEDURE C87A05B IS + + OK : BOOLEAN := TRUE; + TYPE VECTOR IS ARRAY (1 .. 5) OF BOOLEAN; + + PROCEDURE P (ARG : CHARACTER := 'A') IS + BEGIN + OK := FALSE; + END P; + + PROCEDURE P IS + BEGIN + OK := FALSE; + END P; + + PROCEDURE P (ARG : INTEGER) IS -- THIS IS CORRECT P + BEGIN + OK := (ARG = 1); + END P; + + FUNCTION Y RETURN VECTOR IS + BEGIN + OK := FALSE; + RETURN (VECTOR'RANGE => TRUE); + END Y; + + FUNCTION Y RETURN CHARACTER IS + BEGIN + OK := FALSE; + RETURN 'A'; + END Y; + + FUNCTION Y (ARG : FLOAT) RETURN FLOAT IS + BEGIN + OK := FALSE; + RETURN 0.0; + END Y; + + FUNCTION Y (ARG : CHARACTER) RETURN INTEGER IS + BEGIN + OK := FALSE; + RETURN 0; + END Y; + + FUNCTION Y (ARG : FLOAT) RETURN INTEGER IS -- THIS IS CORRECT Y + BEGIN + RETURN 1; + END Y; + + FUNCTION Z RETURN INTEGER IS + BEGIN + OK := FALSE; + RETURN 3; + END Z; + + FUNCTION Z RETURN FLOAT IS -- THIS IS CORRECT Z + BEGIN + RETURN 3.0; + END Z; + +BEGIN + TEST ("C87A05B","OVERLOADING RESOLUTION FOR DISTINGUISHING " & + "FUNCTION CALLS FROM INDEXED COMPONENTS WHERE CORRECT " & + "RESOLUTION IS FUNCTION CALL"); + + P (Y (Z) ); + + IF NOT OK THEN + FAILED ("RESOLUTION INCORRECT"); + END IF; + + RESULT; +END C87A05B; diff --git a/gcc/testsuite/ada/acats/tests/c8/c87b02a.ada b/gcc/testsuite/ada/acats/tests/c8/c87b02a.ada new file mode 100644 index 000000000..9f789c9b2 --- /dev/null +++ b/gcc/testsuite/ada/acats/tests/c8/c87b02a.ada @@ -0,0 +1,124 @@ +-- C87B02A.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 OVERLOADING RESOLUTION USES THE RULE THAT: +-- +-- IN A CONSTANT DECLARATION, THE TYPE OF THE INITIALIZATION +-- EXPRESSION MUST MATCH THE CONSTANT'S EXPLICIT TYPEMARK. +-- +-- THE FOUR KINDS OF EXPRESSIONS TESTED HERE ARE: +-- +-- (A): A CALL TO AN OVERLOADED FUNCTION. +-- (B): AN OVERLOADED OPERATOR SYMBOL. +-- (C): AN OVERLOADED (INFIX) OPERATOR. +-- (D): AN OVERLOADED ENUMERATION LITERAL. + +-- TRH 17 JUNE 82 + +WITH REPORT; USE REPORT; + +PROCEDURE C87B02A IS + + TYPE WHOLE IS NEW INTEGER RANGE 0..INTEGER'LAST; + TYPE CITRUS IS (LEMON, LIME, ORANGE); + TYPE HUE IS (RED, ORANGE, YELLOW); + + FUNCTION F1 (X, Y : INTEGER) RETURN INTEGER IS + BEGIN + RETURN -1; + END F1; + + FUNCTION F1 (X, Y : WHOLE) RETURN WHOLE IS + BEGIN + RETURN 0; + END F1; + + FUNCTION F1 (X, Y : INTEGER) RETURN HUE IS + BEGIN + RETURN ORANGE; + END F1; + + FUNCTION F1 (X, Y : INTEGER) RETURN CITRUS IS + BEGIN + RETURN ORANGE; + END F1; + +BEGIN + TEST ("C87B02A","OVERLOADED INITIALIZATION EXPRESSIONS" & + " IN CONSTANT DECLARATIONS"); + DECLARE + + FUNCTION "*" (X, Y : INTEGER) RETURN INTEGER + RENAMES F1; + + FUNCTION "*" (X, Y : WHOLE) RETURN WHOLE + RENAMES F1; + + FUNCTION "*" (X, Y : INTEGER) RETURN HUE + RENAMES F1; + + FUNCTION "*" (X, Y : INTEGER) RETURN CITRUS + RENAMES F1; + + I1 : CONSTANT INTEGER := F1 (0, 0); + W1 : CONSTANT WHOLE := F1 (0, 0); + C1 : CONSTANT CITRUS := F1 (0, 0); + H1 : CONSTANT HUE := F1 (0, 0); + + I2 : CONSTANT INTEGER := "*" (0, 0); + W2 : CONSTANT WHOLE := "*" (0, 0); + C2 : CONSTANT CITRUS := "*" (0, 0); + H2 : CONSTANT HUE := "*" (0, 0); + + I3 : CONSTANT INTEGER := (0 * 0); + W3 : CONSTANT WHOLE := (0 * 0); + C3 : CONSTANT CITRUS := (0 * 0); + H3 : CONSTANT HUE := (0 * 0); + + C4 : CONSTANT CITRUS := ORANGE; + H4 : CONSTANT HUE := ORANGE; + + BEGIN + IF I1 /= -1 OR W1 /= 0 OR + CITRUS'POS (C1) /= 2 OR HUE'POS (H1) /= 1 THEN + FAILED ("(A): RESOLUTION INCORRECT - FUNCTION CALL"); + END IF; + + IF I2 /= -1 OR W2 /= 0 OR + CITRUS'POS (C2) /= 2 OR HUE'POS (H2) /= 1 THEN + FAILED ("(B): RESOLUTION INCORRECT - OPERATOR SYMBOL"); + END IF; + + IF I3 /= -1 OR W3 /= 0 OR + CITRUS'POS (C3) /= 2 OR HUE'POS (H3) /= 1 THEN + FAILED ("(C): RESOLUTION INCORRECT - INFIX OPERATOR"); + END IF; + + IF CITRUS'POS (C4) /= 2 OR HUE'POS (H4) /= 1 THEN + FAILED ("(D): RESOLUTION INCORRECT - ENUMERATION LITERAL"); + END IF; + END; + + RESULT; +END C87B02A; diff --git a/gcc/testsuite/ada/acats/tests/c8/c87b02b.ada b/gcc/testsuite/ada/acats/tests/c8/c87b02b.ada new file mode 100644 index 000000000..5f2db7c40 --- /dev/null +++ b/gcc/testsuite/ada/acats/tests/c8/c87b02b.ada @@ -0,0 +1,124 @@ +-- C87B02B.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 OVERLOADING RESOLUTION USES THE RULE THAT: +-- +-- IN A VARIABLE DECLARATION, THE TYPE OF THE INITIALIZATION +-- EXPRESSION MUST MATCH THE VARIABLE'S EXPLICIT TYPEMARK. +-- +-- THE FOUR KINDS OF EXPRESSIONS TESTED HERE ARE: +-- +-- (A): A CALL TO AN OVERLOADED FUNCTION. +-- (B): AN OVERLOADED OPERATOR SYMBOL. +-- (C): AN OVERLOADED (INFIX) OPERATOR. +-- (D): AN OVERLOADED ENUMERATION LITERAL. + +-- TRH 17 JUNE 82 + +WITH REPORT; USE REPORT; + +PROCEDURE C87B02B IS + + TYPE WHOLE IS NEW INTEGER RANGE 0..INTEGER'LAST; + TYPE CITRUS IS (LEMON, LIME, ORANGE); + TYPE HUE IS (RED, ORANGE, YELLOW); + + FUNCTION F1 (X, Y : INTEGER) RETURN INTEGER IS + BEGIN + RETURN -1; + END F1; + + FUNCTION F1 (X, Y : WHOLE) RETURN WHOLE IS + BEGIN + RETURN 0; + END F1; + + FUNCTION F1 (X, Y : INTEGER) RETURN HUE IS + BEGIN + RETURN ORANGE; + END F1; + + FUNCTION F1 (X, Y : INTEGER) RETURN CITRUS IS + BEGIN + RETURN ORANGE; + END F1; + +BEGIN + TEST ("C87B02B","OVERLOADED INITIALIZATION EXPRESSIONS" & + " IN VARIABLE DECLARATIONS"); + DECLARE + + FUNCTION "REM" (X, Y : INTEGER) RETURN INTEGER + RENAMES F1; + + FUNCTION "REM" (X, Y : WHOLE) RETURN WHOLE + RENAMES F1; + + FUNCTION "REM" (X, Y : INTEGER) RETURN HUE + RENAMES F1; + + FUNCTION "REM" (X, Y : INTEGER) RETURN CITRUS + RENAMES F1; + + I1 : INTEGER := F1 (0, 0); + W1 : WHOLE := F1 (0, 0); + C1 : CITRUS := F1 (0, 0); + H1 : HUE := F1 (0, 0); + + I2 : INTEGER := "REM" (0, 0); + W2 : WHOLE := "REM" (0, 0); + C2 : CITRUS := "REM" (0, 0); + H2 : HUE := "REM" (0, 0); + + I3 : INTEGER := (0 REM 0); + W3 : WHOLE := (0 REM 0); + C3 : CITRUS := (0 REM 0); + H3 : HUE := (0 REM 0); + + C4 : CITRUS := ORANGE; + H4 : HUE := ORANGE; + + BEGIN + IF I1 /= -1 OR W1 /= 0 OR + CITRUS'POS (C1) /= 2 OR HUE'POS (H1) /= 1 THEN + FAILED ("(A): RESOLUTION INCORRECT - FUNCTION CALL"); + END IF; + + IF I2 /= -1 OR W2 /= 0 OR + CITRUS'POS (C2) /= 2 OR HUE'POS (H2) /= 1 THEN + FAILED ("(B): RESOLUTION INCORRECT - OPERATOR SYMBOL"); + END IF; + + IF I3 /= -1 OR W3 /= 0 OR + CITRUS'POS (C3) /= 2 OR HUE'POS (H3) /= 1 THEN + FAILED ("(C): RESOLUTION INCORRECT - INFIX OPERATOR"); + END IF; + + IF CITRUS'POS (C4) /= 2 OR HUE'POS (H4) /= 1 THEN + FAILED ("(D): RESOLUTION INCORRECT - ENUMERATION LITERAL"); + END IF; + END; + + RESULT; +END C87B02B; diff --git a/gcc/testsuite/ada/acats/tests/c8/c87b03a.ada b/gcc/testsuite/ada/acats/tests/c8/c87b03a.ada new file mode 100644 index 000000000..d0b372237 --- /dev/null +++ b/gcc/testsuite/ada/acats/tests/c8/c87b03a.ada @@ -0,0 +1,61 @@ +-- C87B03A.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 OVERLOADING RESOLUTION USES THE RULE THAT: +-- +-- THE EXPRESSION IN A NUMBER DECLARATION MUST BE EITHER OF THE TYPE +-- UNIVERSAL_INTEGER OR UNIVERSAL_REAL. + +-- TRH 16 JUNE 82 + +WITH REPORT; USE REPORT; + +PROCEDURE C87B03A IS + +BEGIN + TEST ("C87B03A","OVERLOADED EXPRESSIONS IN NUMBER DECLARATIONS"); + + DECLARE + FUNCTION "+" (X, Y : INTEGER) RETURN INTEGER + RENAMES STANDARD."-"; + + FUNCTION "+" (X, Y : FLOAT) RETURN FLOAT + RENAMES STANDARD."-"; + + I1 : CONSTANT := 1 + 1; + I2 : CONSTANT INTEGER := 1 + 1; + + R1 : CONSTANT := 1.0 + 1.0; + R2 : CONSTANT FLOAT := 1.0 + 1.0; + + BEGIN + IF I1 /= 2 OR I2 /= 0 OR + R1 /= 2.0 OR R2 /= 0.0 THEN + FAILED ("OVERLOADED EXPRESSIONS IN NUMBER DECLARATIONS" & + " RESOLVED INCORRECTLY"); + END IF; + END; + + RESULT; +END C87B03A; diff --git a/gcc/testsuite/ada/acats/tests/c8/c87b04a.ada b/gcc/testsuite/ada/acats/tests/c8/c87b04a.ada new file mode 100644 index 000000000..ea2e65c1a --- /dev/null +++ b/gcc/testsuite/ada/acats/tests/c8/c87b04a.ada @@ -0,0 +1,79 @@ +-- C87B04A.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 OVERLOADING RESOLUTION USES THE RULE THAT: +-- +-- IN A RANGE CONSTRAINT OF A SUBTYPE INDICATION, THE EXPRESSIONS +-- FOR THE LOWER AND UPPER BOUNDS MUST BE COMPATIBLE WITH THE SUBTYPE'S +-- EXPLICIT TYPEMARK. + +-- TRH 28 JUNE 82 +-- JBG 3/8/84 + +WITH REPORT; USE REPORT; +PROCEDURE C87B04A IS + + TYPE AGE IS NEW INTEGER RANGE 1 .. 120; + TYPE BASE10 IS NEW INTEGER RANGE 0 .. 9; + + FUNCTION F1 RETURN AGE IS + BEGIN + RETURN 18; + END F1; + + FUNCTION F1 RETURN INTEGER IS + BEGIN + FAILED ("RESOLUTION INCORRECT - RANGE CONSTRAINT OF " & + "SUBTYPE INDICATION"); + RETURN 0; + END F1; + + FUNCTION "+" (X : INTEGER) RETURN BASE10 IS + BEGIN + RETURN 1; + END "+"; + + FUNCTION "+" (X : INTEGER) RETURN INTEGER IS + BEGIN + FAILED ("RESOLUTION INCORRECT - RANGE CONSTRAINT OF " & + "SUBTYPE INDICATION"); + RETURN -X; + END "+"; + +BEGIN + TEST ("C87B04A","OVERLOADED EXPRESSIONS IN RANGE CONTRAINTS" & + " OF SUBTYPE INDICATIONS"); + + DECLARE + SUBTYPE MINOR IS AGE RANGE 1 .. F1; + + BEGIN + FOR I IN BASE10 RANGE +(INTEGER'(0)) .. 0 LOOP + FAILED ("RESOLUTION INCORRECT - SUBTYPE INDICATION " & + " IN LOOP CONSTRUCT"); + END LOOP; + END; + + RESULT; +END C87B04A; diff --git a/gcc/testsuite/ada/acats/tests/c8/c87b04b.ada b/gcc/testsuite/ada/acats/tests/c8/c87b04b.ada new file mode 100644 index 000000000..681011ba3 --- /dev/null +++ b/gcc/testsuite/ada/acats/tests/c8/c87b04b.ada @@ -0,0 +1,82 @@ +-- C87B04B.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 OVERLOADING RESOLUTION USES THE RULE THAT: + +-- IN AN ACCURACY CONSTRAINT OF A SUBTYPE INDICATION, THE +-- EXPRESSIONS FOR THE LOWER AND UPPER BOUNDS MUST BE COMPATIBLE +-- WITH THE SUBTYPE'S EXPLICIT TYPEMARK. + +-- HISTORY: +-- TRH 06/29/82 CREATED ORIGINAL TEST. +-- BCB 11/12/87 CHANGED HEADER TO STANDARD FORMAT. CORRECTED +-- CONSTRAINT ERRORS. +-- KAS 11/24/95 DELETED SUBTYPE DIGITS CONSTRAINT + +WITH REPORT; USE REPORT; + +PROCEDURE C87B04B IS + + TYPE EXACT IS DIGITS 5 RANGE -1.0 .. 1.0; + TYPE HEX IS DELTA 2.0 ** (-4) RANGE -1.0 .. 1.0; + + FUNCTION F1 RETURN EXACT IS + BEGIN + RETURN 0.0; + END F1; + + FUNCTION F1 RETURN FLOAT IS + BEGIN + FAILED ("RESOLUTION INCORRECT - ACCURACY CONSTRAINT OF " & + "SUBTYPE INDICATION - F1"); + RETURN 0.0; + END F1; + + FUNCTION "+" (X : INTEGER) RETURN HEX IS + BEGIN + RETURN 0.0; + END "+"; + + FUNCTION "+" (X : INTEGER) RETURN FLOAT IS + BEGIN + FAILED ("RESOLUTION INCORRECT - ACCURACY CONSTRAINT OF " & + "SUBTYPE INDICATION - +"); + RETURN 0.0; + END "+"; + +BEGIN + TEST ("C87B04B","OVERLOADED EXPRESSIONS IN ACCURACY CONTRAINTS" & + " OF FLOATING/FIXED POINT SUBTYPE INDICATIONS"); + + DECLARE + SUBTYPE CLOSE IS EXACT RANGE -1.0 .. F1; + SUBTYPE BIN IS HEX DELTA 2.0 ** (-1) RANGE "+" (0) .. 0.5; + + BEGIN + NULL; + END; + + RESULT; +END C87B04B; diff --git a/gcc/testsuite/ada/acats/tests/c8/c87b04c.ada b/gcc/testsuite/ada/acats/tests/c8/c87b04c.ada new file mode 100644 index 000000000..df67059b5 --- /dev/null +++ b/gcc/testsuite/ada/acats/tests/c8/c87b04c.ada @@ -0,0 +1,60 @@ +-- C87B04C.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 OVERLOADING RESOLUTION USES THE RULE THAT: +-- +-- IN A RANGE CONSTRAINT OF A SUBTYPE INDICATION, THE EXPRESSIONS +-- FOR THE LOWER AND UPPER BOUNDS MUST BE COMPATIBLE WITH THE SUBTYPE'S +-- EXPLICIT TYPEMARK. + +-- TRH 29 JUNE 82 + +WITH REPORT; USE REPORT; + +PROCEDURE C87B04C IS + + TYPE DAY IS (MON, TUE, WED, THU, FRI, SAT, SUN); + TYPE ORB IS (SUN, MOON, MARS, EARTH); + + TYPE GRADE IS ('A', 'B', 'C', 'D', 'F'); + TYPE VOWEL IS ('C', 'E', 'A', 'O', 'I', 'U', 'Y'); + +BEGIN + TEST ("C87B04C","OVERLOADED EXPRESSIONS IN RANGE CONSTRAINTS" & + " OF ENUMERATION SUBTYPE INDICATIONS"); + + DECLARE + SUBTYPE PASSING IS GRADE RANGE 'A' .. 'C'; + SUBTYPE DISTANT IS ORB RANGE SUN .. MARS; + + BEGIN + IF DISTANT'POS (DISTANT'FIRST) /= 0 OR + PASSING'POS (PASSING'FIRST) /= 0 THEN + FAILED ("RESOLUTION INCORRECT FOR OVERLOADED " & + " ENUMERATION LITERALS"); + END IF; + END; + + RESULT; +END C87B04C; diff --git a/gcc/testsuite/ada/acats/tests/c8/c87b05a.ada b/gcc/testsuite/ada/acats/tests/c8/c87b05a.ada new file mode 100644 index 000000000..f50ce379b --- /dev/null +++ b/gcc/testsuite/ada/acats/tests/c8/c87b05a.ada @@ -0,0 +1,70 @@ +-- C87B05A.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 OVERLOADING RESOLUTION USES THE RULE THAT: +-- +-- IN AN INTEGER TYPE DEFINITION WITH A RANGE CONSTRAINT, THE BOUNDS +-- OF THE RANGE MUST BE OF SOME INTEGER TYPE. + +-- TRH 1 JULY 82 + +WITH REPORT; USE REPORT; + +PROCEDURE C87B05A IS + + ERR : BOOLEAN := FALSE; + TYPE WHOLE IS NEW INTEGER RANGE 0 .. INTEGER'LAST; + TYPE AGE IS NEW INTEGER RANGE 0 .. 120; + + FUNCTION "+" (X : WHOLE) RETURN FLOAT IS + BEGIN + ERR := TRUE; + RETURN 2.0; + END "+"; + + FUNCTION "-" (X : AGE) RETURN BOOLEAN IS + BEGIN + ERR := TRUE; + RETURN FALSE; + END "-"; + +BEGIN + TEST ("C87B05A","OVERLOADED EXPRESSIONS IN RANGE BOUNDS " & + " OF INTEGER TYPE DEFINITIONS"); + + DECLARE + TYPE ADULT IS RANGE 18 .. "+" (WHOLE'(120)); + TYPE MINOR IS RANGE "-" (AGE'(0)) .. "+" (WHOLE'(17)); + TYPE NEG10 IS RANGE "-" (AGE'(10)) .. "-" (AGE'(1)); + + BEGIN + IF ERR THEN + FAILED ("RESOLUTION INCORRECT - INTEGER TYPE " & + "DEFINITIONS MUST HAVE INTEGER TYPE " & + "RANGE BOUNDS"); + END IF; + END; + + RESULT; +END C87B05A; diff --git a/gcc/testsuite/ada/acats/tests/c8/c87b06a.ada b/gcc/testsuite/ada/acats/tests/c8/c87b06a.ada new file mode 100644 index 000000000..a5c64b4b4 --- /dev/null +++ b/gcc/testsuite/ada/acats/tests/c8/c87b06a.ada @@ -0,0 +1,90 @@ +-- C87B06A.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 OVERLOADING RESOLUTION USES THE RULE THAT: +-- +-- FOR EACH INTEGER TYPE, THERE EXISTS AN IMPLICIT CONVERSION THAT +-- CONVERTS A UNIVERSAL INTEGER VALUE INTO THE CORRESPONDING VALUE +-- OF THE INTEGER TYPE. THIS TEST USES LITERALS AS UNIVERSAL INTEGER +-- VALUES. + +-- HISTORY: +-- TRH 08/11/82 CREATED ORIGINAL TEST. +-- DHH 10/20/87 SHORTENED LINES CONTAINING MORE THAN 72 CHARACTERS. + +WITH REPORT; USE REPORT; + +PROCEDURE C87B06A IS + + TYPE MINOR IS NEW INTEGER RANGE 0 .. 17; + TYPE FIXED IS NEW DURATION; + TYPE REAL IS NEW FLOAT; + + ERR : BOOLEAN := FALSE; + + PROCEDURE P (X : BOOLEAN) IS + BEGIN + ERR := TRUE; + END P; + PROCEDURE P (X : FIXED) IS + BEGIN + ERR := TRUE; + END P; + + PROCEDURE P (X : REAL) IS + BEGIN + ERR := TRUE; + END P; + + PROCEDURE P (X : FLOAT) IS + BEGIN + ERR := TRUE; + END P; + + PROCEDURE P (X : STRING) IS + BEGIN + ERR := TRUE; + END P; + + PROCEDURE P (X : MINOR) IS + BEGIN + NULL; + END P; + +BEGIN + TEST("C87B06A","OVERLOADING RESOLUTION WITH IMPLICIT CONVERSION " & + "OF UNIVERSAL INTEGER VALUES TO INTEGER VALUES. " & + "CONVERSIONS TO INTEGER VALUES EXISTS FOR ANY INTEGER TYPE"); + + P (2); + P (2 * 2 + 2); + + IF ERR THEN + FAILED("INCORRECT IMPLICIT CONVERSION FROM UNIVERSAL " & + " INTEGER VALUES TO INTEGER TYPE VALUES"); + END IF; + + RESULT; +END C87B06A; diff --git a/gcc/testsuite/ada/acats/tests/c8/c87b07a.ada b/gcc/testsuite/ada/acats/tests/c8/c87b07a.ada new file mode 100644 index 000000000..635a8fc65 --- /dev/null +++ b/gcc/testsuite/ada/acats/tests/c8/c87b07a.ada @@ -0,0 +1,64 @@ +-- C87B07A.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 OVERLOADING RESOLUTION USES THE RULE THAT: +-- +-- FOR THE ATTRIBUTE OF THE FORM T'POS (X), THE OPERAND X MUST +-- BE A VALUE OF TYPE T. THE RESULT IS OF TYPE UNIVERSAL_INTEGER. + +-- TRH 13 SEPT 82 + +WITH REPORT; USE REPORT; + +PROCEDURE C87B07A IS + + TYPE NATURAL IS NEW INTEGER RANGE 1 .. INTEGER'LAST; + TYPE WHOLE IS NEW INTEGER RANGE 0 .. INTEGER'LAST; + TYPE COLOR IS (BROWN, RED, WHITE); + TYPE SCHOOL IS (HARVARD, BROWN, YALE); + TYPE SUGAR IS (DEXTROSE, CANE, BROWN); + + FUNCTION "+" (X, Y : NATURAL) RETURN NATURAL + RENAMES "*"; + FUNCTION "+" (X, Y : WHOLE) RETURN WHOLE + RENAMES "-"; + +BEGIN + TEST ("C87B07A","OVERLOADED OPERANDS TO THE 'POS' ATTRIBUTE"); + + IF NATURAL'POS (1 + 1) /= 1 OR COLOR'POS (BROWN) /= 0 OR + WHOLE'POS (1 + 1) /= 0 OR SCHOOL'POS (BROWN) /= 1 OR + INTEGER'POS (1 + 1) /= 2 OR SUGAR'POS (BROWN) /= 2 THEN + FAILED ("RESOLUTION INCORRECT FOR OPERAND TO 'POS' ATTRIBUTE"); + END IF; + + IF NATURAL'POS (3 + 3) + 1 /= 10 OR -- SECOND "+" IS UNIVERSAL. + WHOLE'POS (3 + 3) + 1 /= 1 OR -- SECOND "+" IS UNIVERSAL. + INTEGER'POS (3 + 3) + 1 /= 7 THEN -- SECOND "+" IS UNIVERSAL. + FAILED ("RESOLUTION INCORRECT - 'POS' ATTRIBUTE RETURNS " & + "A UNIVERSAL_INTEGER VALUE"); + END IF; + + RESULT; +END C87B07A; diff --git a/gcc/testsuite/ada/acats/tests/c8/c87b07b.ada b/gcc/testsuite/ada/acats/tests/c8/c87b07b.ada new file mode 100644 index 000000000..ec2c0a193 --- /dev/null +++ b/gcc/testsuite/ada/acats/tests/c8/c87b07b.ada @@ -0,0 +1,101 @@ +-- C87B07B.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 OVERLOADING RESOLUTION USES THE RULE THAT: +-- +-- FOR THE ATTRIBUTE OF THE FORM T'VAL (X), THE OPERAND X MAY +-- BE OF ANY INTEGER TYPE. THE RESULT IS OF TYPE T. + +-- TRH 15 SEPT 82 +-- DSJ 06 JUNE 83 +-- PWN 01/31/95 REMOVED INCONSISTENCIES WITH ADA 9X. + +WITH REPORT; USE REPORT; + +PROCEDURE C87B07B IS + + TYPE NEW_INT IS NEW INTEGER; + TYPE WHOLE IS NEW INTEGER RANGE 0 .. INTEGER'LAST; + TYPE FLAG IS (PASS, FAIL); + + FUNCTION "+" (X, Y : NEW_INT) RETURN NEW_INT + RENAMES "-"; + FUNCTION "+" (X, Y : WHOLE) RETURN WHOLE + RENAMES "*"; + + GENERIC + TYPE T IS PRIVATE; + ARG : IN T; + STAT : IN FLAG; + FUNCTION F1 RETURN T; + + FUNCTION F1 RETURN T IS + BEGIN + IF STAT = FAIL THEN + FAILED ("THE 'VAL' ATTRIBUTE TAKES AN OPERAND " & + "OF AN INTEGER TYPE"); + END IF; + RETURN ARG; + END F1; + + FUNCTION F IS NEW F1 (CHARACTER, '1', FAIL); + FUNCTION F IS NEW F1 (DURATION, 1.0, FAIL); + FUNCTION F IS NEW F1 (FLOAT, 1.0, FAIL); + FUNCTION F IS NEW F1 (NEW_INT, 1, PASS); + +BEGIN + TEST ("C87B07B","OVERLOADED OPERANDS TO THE 'VAL' ATTRIBUTE"); + + IF (INTEGER'VAL (F) /= 1) THEN + FAILED ("RESOLUTION INCORRECT - THE 'VAL' ATTRIBUTE " & + "MUST RETURN A VALUE OF TYPE T - 1"); + END IF; + + IF (INTEGER'VAL (3 + 3) + 1 /= 7) THEN + FAILED ("RESOLUTION INCORRECT - THE 'VAL' ATTRIBUTE " & + "MUST RETURN A VALUE OF TYPE T - 2"); + END IF; + + IF (NEW_INT'VAL (F) /= 1) THEN + FAILED ("RESOLUTION INCORRECT - THE 'VAL' ATTRIBUTE " & + "MUST RETURN A VALUE OF TYPE T - 3"); + END IF; + + IF (NEW_INT'VAL (3 + 3) + 1 /= 5) THEN + FAILED ("RESOLUTION INCORRECT - THE 'VAL' ATTRIBUTE " & + "MUST RETURN A VALUE OF TYPE T - 4"); + END IF; + + IF (WHOLE'VAL (F) /= 1) THEN + FAILED ("RESOLUTION INCORRECT - THE 'VAL' ATTRIBUTE " & + "MUST RETURN A VALUE OF TYPE T - 5"); + END IF; + + IF (WHOLE'VAL (3 + 3) + 1 /= 6) THEN + FAILED ("RESOLUTION INCORRECT - THE 'VAL' ATTRIBUTE " & + "MUST RETURN A VALUE OF TYPE T - 6"); + END IF; + + RESULT; +END C87B07B; diff --git a/gcc/testsuite/ada/acats/tests/c8/c87b07c.ada b/gcc/testsuite/ada/acats/tests/c8/c87b07c.ada new file mode 100644 index 000000000..851143a50 --- /dev/null +++ b/gcc/testsuite/ada/acats/tests/c8/c87b07c.ada @@ -0,0 +1,85 @@ +-- C87B07C.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 OVERLOADING RESOLUTION USES THE RULE THAT: +-- +-- FOR THE ATTRIBUTE OF THE FORM T'VALUE (X), THE OPERAND X MUST +-- BE OF THE PREDEFINED TYPE STRING. THE RESULT IS OF TYPE T. + +-- TRH 13 SEPT 82 +-- PWN 01/31/95 REMOVED INCONSISTENCIES WITH ADA 9X. + +WITH REPORT; USE REPORT; + +PROCEDURE C87B07C IS + + TYPE CHAR IS NEW CHARACTER; + TYPE LITS IS (' ', '+', '1'); + TYPE WORD IS ARRAY (POSITIVE RANGE 1..4) OF CHARACTER; + TYPE LINE IS ARRAY (POSITIVE RANGE 1..4) OF CHAR; + TYPE LIST IS ARRAY (POSITIVE RANGE 1..4) OF LITS; + TYPE STR IS ARRAY (POSITIVE RANGE 1..4) OF STRING (1 .. 1); + TYPE STR2 IS NEW STRING (1..4); + TYPE FLAG IS (PASS, FAIL); + SUBTYPE MY_STRING IS STRING (1..4); + + GENERIC + TYPE T IS PRIVATE; + ARG : IN T; + STAT : IN FLAG; + FUNCTION F1 RETURN T; + + FUNCTION F1 RETURN T IS + BEGIN + IF STAT = FAIL THEN + FAILED ("THE 'VALUE' ATTRIBUTE TAKES AN OPERAND" & + " OF THE TYPE PREDEFINED STRING"); + END IF; + RETURN ARG; + END F1; + + FUNCTION F IS NEW F1 (STR2, " +1 ", FAIL); + FUNCTION F IS NEW F1 (LIST, " +1 ", FAIL); + FUNCTION F IS NEW F1 (WORD, (' ', '+', '1', ' '), FAIL); + FUNCTION F IS NEW F1 (STR, (" ", "+", "1", " "), FAIL); + FUNCTION F IS NEW F1 (LINE, (' ', '+', '1', ' '), FAIL); + FUNCTION F IS NEW F1 (MY_STRING, " +1 ", PASS); + +BEGIN + TEST ("C87B07C","OVERLOADED OPERANDS TO THE 'VALUE' ATTRIBUTE"); + + DECLARE + TYPE INT IS NEW INTEGER; + FUNCTION "-" (X : INT) RETURN INT + RENAMES "+"; + + BEGIN + IF INT'VALUE (F) /= -1 THEN + FAILED ("THE ATTRIBUTE T'VALUE MUST RETURN A VALUE" & + " OF TYPE T"); + END IF; + END; + + RESULT; +END C87B07C; diff --git a/gcc/testsuite/ada/acats/tests/c8/c87b07d.ada b/gcc/testsuite/ada/acats/tests/c8/c87b07d.ada new file mode 100644 index 000000000..0e93649d7 --- /dev/null +++ b/gcc/testsuite/ada/acats/tests/c8/c87b07d.ada @@ -0,0 +1,59 @@ +-- C87B07D.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 OVERLOADING RESOLUTION USES THE RULE THAT: +-- +-- THE ATTRIBUTES OF THE FORM T'SUCC (X) AND T'PRED (X) TAKE AN +-- OPERAND X OF TYPE T AND RETURN A VALUE OF TYPE T. + +-- TRH 15 SEPT 82 + +WITH REPORT; USE REPORT; + +PROCEDURE C87B07D IS + + TYPE NEW_INT IS NEW INTEGER; + TYPE WHOLE IS NEW INTEGER RANGE 0 .. INTEGER'LAST; + + FUNCTION "+" (X, Y : WHOLE) RETURN WHOLE + RENAMES "*"; + FUNCTION "+" (X, Y : NEW_INT) RETURN NEW_INT + RENAMES "-"; + +BEGIN + TEST ("C87B07D","OVERLOADED OPERANDS TO THE ATTRIBUTES " & + "'PRED' AND 'SUCC'"); + + IF INTEGER'SUCC (1 + 1) /= 3 OR INTEGER'SUCC (3 + 3) + 1 /= 8 OR + NEW_INT'SUCC (1 + 1) /= 1 OR NEW_INT'SUCC (3 + 3) + 1 /= 0 OR + WHOLE'SUCC (1 + 1) /= 2 OR WHOLE'SUCC (3 + 3) + 1 /= 10 OR + INTEGER'PRED (1 + 1) /= 1 OR INTEGER'PRED (3 + 3) + 1 /= 6 OR + NEW_INT'PRED (1 + 1) /= -1 OR NEW_INT'PRED (3 + 3) + 1 /= -2 OR + WHOLE'PRED (1 + 1) /= 0 OR WHOLE'PRED (3 + 3) + 1 /= 8 + THEN FAILED ("RESOLUTION INCORRECT FOR OPERAND OR RESULT OF" & + " THE 'PRED' OR 'SUCC' ATTRIBUTE"); + END IF; + + RESULT; +END C87B07D; diff --git a/gcc/testsuite/ada/acats/tests/c8/c87b07e.ada b/gcc/testsuite/ada/acats/tests/c8/c87b07e.ada new file mode 100644 index 000000000..83e5c906a --- /dev/null +++ b/gcc/testsuite/ada/acats/tests/c8/c87b07e.ada @@ -0,0 +1,69 @@ +-- C87B07E.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 OVERLOADING RESOLUTION USES THE RULE THAT: +-- +-- FOR THE ATTRIBUTE OF THE FORM T'IMAGE (X), THE OPERAND X MUST +-- BE OF TYPE T. THE RESULT IS OF THE PREDEFINED TYPE STRING. + +-- TRH 15 SEPT 82 + +WITH REPORT; USE REPORT; + +PROCEDURE C87B07E IS + + TYPE NEW_INT IS NEW INTEGER; + TYPE NUMBER IS NEW INTEGER; + TYPE NEW_STR IS NEW STRING; + + FUNCTION "+" (X : NEW_INT) RETURN NEW_INT + RENAMES "-"; + FUNCTION "-" (X : NUMBER) RETURN NUMBER + RENAMES "+"; + + PROCEDURE P (X : NEW_STR) IS + BEGIN + FAILED ("THE IMAGE ATTRIBUTE MUST RETURN A VALUE OF THE" & + " PREDEFINED TYPE STRING"); + END P; + + PROCEDURE P (X : STRING) IS + BEGIN + NULL; + END P; + +BEGIN + TEST ("C87B07E","OVERLOADED OPERANDS TO THE IMAGE ATTRIBUTE"); + + IF INTEGER'IMAGE (+12) & INTEGER'IMAGE (-12) & + NEW_INT'IMAGE (+12) & NEW_INT'IMAGE (-12) & + NUMBER'IMAGE (+12) & NUMBER'IMAGE (-12) /= + " 12-12-12-12 12 12" THEN + FAILED ("RESOLUTION INCORRECT FOR THE 'IMAGE' ATTRIBUTE"); + END IF; + + P (INTEGER'IMAGE (+1) & NEW_INT'IMAGE (+1) & NUMBER'IMAGE (-1)); + + RESULT; +END C87B07E; diff --git a/gcc/testsuite/ada/acats/tests/c8/c87b08a.ada b/gcc/testsuite/ada/acats/tests/c8/c87b08a.ada new file mode 100644 index 000000000..b9998455e --- /dev/null +++ b/gcc/testsuite/ada/acats/tests/c8/c87b08a.ada @@ -0,0 +1,72 @@ +-- C87B08A.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 OVERLOADING RESOLUTION USES THE RULE THAT: +-- +-- FOR EACH REAL TYPE, THERE EXISTS AN IMPLICIT CONVERSION THAT +-- CONVERTS A UNIVERSAL REAL VALUE INTO THE CORRESPONDING VALUE +-- OF THE REAL TYPE. THIS TEST USES LITERALS AS UNIVERSAL REAL +-- VALUES. + +-- TRH 16 AUG 82 +-- PWN 01/31/95 REMOVED INCONSISTENCIES WITH ADA 9X. + +WITH REPORT; USE REPORT; + +PROCEDURE C87B08A IS + + TYPE FIXED IS DELTA 0.1 RANGE -2.0 .. 2.0; + TYPE FLT IS DIGITS 2 RANGE -2.0 .. 2.0; + TYPE FLAG IS (PASS, FAIL); + + GENERIC + TYPE T IS PRIVATE; + STAT : IN FLAG; + PROCEDURE P1 (X : T); + + PROCEDURE P1 (X : T) IS + BEGIN + IF STAT = FAIL THEN + FAILED ("INCORRECT IMPLICIT CONVERSION FROM UNIVERSAL" & + " REAL VALUES TO REAL TYPE VALUES"); + END IF; + END P1; + + PROCEDURE P IS NEW P1 (INTEGER, FAIL); + PROCEDURE P IS NEW P1 (FLT, PASS); + PROCEDURE Q IS NEW P1 (FIXED, PASS); + PROCEDURE Q IS NEW P1 (BOOLEAN, FAIL); + PROCEDURE Q IS NEW P1 (CHARACTER, FAIL); + +BEGIN + TEST ("C87B08A","IMPLICIT CONVERSION OF UNIVERSAL REAL " & + "VALUES TO REAL VALUES EXISTS FOR ANY REAL TYPE"); + + P (0.0); + P (1.0 + 1.0); + Q (1.0); + Q (1.0 - 1.0); + + RESULT; +END C87B08A; diff --git a/gcc/testsuite/ada/acats/tests/c8/c87b09a.ada b/gcc/testsuite/ada/acats/tests/c8/c87b09a.ada new file mode 100644 index 000000000..bcdcad642 --- /dev/null +++ b/gcc/testsuite/ada/acats/tests/c8/c87b09a.ada @@ -0,0 +1,55 @@ +-- C87B09A.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 OVERLOADING RESOLUTION USES THE RULE THAT: +-- +-- IN A FLOATING POINT TYPE DEFINITION, THE DIGITS EXPRESSION MUST +-- BE OF SOME INTEGER TYPE. + +-- TRH 30 JUNE 82 + +WITH REPORT; USE REPORT; + +PROCEDURE C87B09A IS + + FUNCTION "+" (X : INTEGER) RETURN FLOAT IS + BEGIN + FAILED ("DIGITS EXPRESSION MUST BE OF AN INTEGER TYPE"); + RETURN 2.0; + END "+"; + +BEGIN + TEST ("C87B09A","OVERLOADED DIGITS EXPRESSIONS IN " & + "FLOATING POINT TYPE DEFINITIONS"); + + DECLARE + TYPE EXACT IS DIGITS "+" (3); + TYPE CLOSE IS DIGITS "+" (1) RANGE -1.0 .. 1.0; + + BEGIN + NULL; + END; + + RESULT; +END C87B09A; diff --git a/gcc/testsuite/ada/acats/tests/c8/c87b09c.ada b/gcc/testsuite/ada/acats/tests/c8/c87b09c.ada new file mode 100644 index 000000000..4a7ce12cd --- /dev/null +++ b/gcc/testsuite/ada/acats/tests/c8/c87b09c.ada @@ -0,0 +1,64 @@ +-- C87B09C.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 OVERLOADING RESOLUTION USES THE RULE THAT: +-- +-- IN A FLOATING POINT TYPE DEFINITION, THE DIGITS EXPRESSION MUST +-- BE OF SOME INTEGRAL TYPE. SIMILARLY, THE DELTA EXPRESSION IN A +-- FIXED POINT TYPE DEFINITION MUST BE OF SOME REAL TYPE. + +-- TRH 30 JUNE 82 + +WITH REPORT; USE REPORT; + +PROCEDURE C87B09C IS + + FUNCTION "+" (X : INTEGER) RETURN FLOAT IS + BEGIN + FAILED ("DIGITS EXPRESSION MUST BE OF AN INTEGRAL TYPE"); + RETURN 2.0; + END "+"; + + FUNCTION "+" (X : FLOAT) RETURN INTEGER IS + BEGIN + FAILED ("DELTA EXPRESSION MUST BE OF A REAL TYPE"); + RETURN 2; + END "+"; + +BEGIN + TEST ("C87B09C","OVERLOADED DIGITS/DELTA EXPRESSIONS IN " & + "REAL TYPE DEFINITIONS"); + + DECLARE + TYPE EXACT IS DIGITS "+" (4); + TYPE CENTI IS DELTA "+" (0.01) RANGE -2.0 .. 2.0; + TYPE CLOSE IS DIGITS "+" (2) RANGE -1.0 .. 1.0; + TYPE DECI IS DELTA "+" (0.1) RANGE -1.0 .. 1.0; + + BEGIN + NULL; + END; + + RESULT; +END C87B09C; diff --git a/gcc/testsuite/ada/acats/tests/c8/c87b10a.ada b/gcc/testsuite/ada/acats/tests/c8/c87b10a.ada new file mode 100644 index 000000000..a09db6052 --- /dev/null +++ b/gcc/testsuite/ada/acats/tests/c8/c87b10a.ada @@ -0,0 +1,75 @@ +-- C87B10A.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 OVERLOADING RESOLUTION USES THE RULE THAT: +-- +-- IN A RANGE CONSTRAINT OF A FIXED POINT OR FLOATING POINT TYPE +-- DEFINITION, BOTH BOUNDS MUST BE OF SOME REAL TYPE, ALTHOUGH +-- THE TWO BOUNDS DO NOT HAVE TO BE OF THE SAME TYPE. + +-- TRH 7/28/82 +-- DSJ 6/10/83 +-- JBG 9/19/84 + +WITH REPORT; USE REPORT; + +PROCEDURE C87B10A IS + + SUBTYPE DUR IS DURATION; + + FUNCTION "+" (X : FLOAT) RETURN INTEGER IS + BEGIN + FAILED ("RANGE CONSTRAINT FOR REAL TYPE DEFINITIONS " & + "MUST HAVE REAL BOUNDS"); + RETURN -10; + END "+"; + + FUNCTION "+" (X, Y : FLOAT) RETURN INTEGER IS + BEGIN + FAILED ("RANGE CONSTRAINT FOR REAL TYPE DEFINITIONS " & + "MUST HAVE REAL BOUNDS"); + RETURN -10; + END "+"; + +BEGIN + TEST ("C87B10A","RANGE BOUNDS IN REAL TYPE DEFINITIONS MUST BE" & + " OF SOME (NOT NECESSARILY THE SAME) REAL TYPE"); + + DECLARE + TYPE R1 IS DIGITS 2 RANGE 0.0 .. 1.0 + FLOAT'(1.0); + TYPE R2 IS DELTA 0.1 RANGE FLOAT'(1.0) + 1.0 .. DUR'(2.0); + TYPE R3 IS DIGITS 2 RANGE +1.0 .. "+" (FLOAT'(2.0), 2.0); + TYPE R4 IS DELTA 0.1 RANGE 0.0 + FLOAT'(0.0) .. +1.0; + + + BEGIN + IF 2.0 NOT IN R1 OR -1.0 IN R2 OR + -1.0 IN R3 OR -0.9 IN R4 THEN + FAILED ("RANGE BOUNDS IN REAL TYPE DEFINITIONS DO NOT " + & "HAVE TO BE OF THE SAME REAL TYPE"); + END IF; + END; + + RESULT; +END C87B10A; diff --git a/gcc/testsuite/ada/acats/tests/c8/c87b11a.ada b/gcc/testsuite/ada/acats/tests/c8/c87b11a.ada new file mode 100644 index 000000000..07a373723 --- /dev/null +++ b/gcc/testsuite/ada/acats/tests/c8/c87b11a.ada @@ -0,0 +1,55 @@ +-- C87B11A.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 OVERLOADING RESOLUTION USES THE RULE THAT: +-- +-- IN A FIXED POINT TYPE DEFINITION, THE DELTA EXPRESSION MUST +-- BE OF SOME REAL TYPE. + +-- TRH 30 JUNE 82 + +WITH REPORT; USE REPORT; + +PROCEDURE C87B11A IS + + FUNCTION "+" (X : FLOAT) RETURN INTEGER IS + BEGIN + FAILED ("DELTA EXPRESSION MUST BE OF A REAL TYPE"); + RETURN 2; + END "+"; + +BEGIN + TEST ("C87B11A","OVERLOADED DELTA EXPRESSIONS IN " & + "FIXED POINT TYPE DEFINITIONS"); + + DECLARE + TYPE SEMI IS DELTA "+" (0.5) RANGE -2.0 .. 2.0; + TYPE DECI IS DELTA "+" (0.1) RANGE -1.0 .. 1.0; + + BEGIN + NULL; + END; + + RESULT; +END C87B11A; diff --git a/gcc/testsuite/ada/acats/tests/c8/c87b11b.ada b/gcc/testsuite/ada/acats/tests/c8/c87b11b.ada new file mode 100644 index 000000000..654603aff --- /dev/null +++ b/gcc/testsuite/ada/acats/tests/c8/c87b11b.ada @@ -0,0 +1,57 @@ +-- C87B11B.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 OVERLOADING RESOLUTION USES THE RULE THAT: +-- +-- IN A SUBTYPE INDICATION, THE DELTA EXPRESSION FOR A FIXED POINT +-- NUMBER MUST BE OF SOME REAL TYPE. + +-- TRH 29 JUNE 82 + +WITH REPORT; USE REPORT; + +PROCEDURE C87B11B IS + + TYPE DELT3 IS DELTA 3.0 RANGE -30.0 .. 30.0; + + FUNCTION "+" (X : FLOAT) RETURN INTEGER IS + BEGIN + FAILED ("DELTA EXPRESSION MUST BE OF A REAL TYPE"); + RETURN 2; + END "+"; + +BEGIN + TEST ("C87B11B","OVERLOADED DELTA EXPRESSIONS IN " & + "FIXED POINT SUBTYPE INDICATIONS"); + + DECLARE + SUBTYPE DELT2 IS DELT3 DELTA "+"(6.0); + SUBTYPE DELT1 IS DELT3 DELTA "+"(10.0) RANGE -10.0 .. 10.0; + + BEGIN + NULL; + END; + + RESULT; +END C87B11B; diff --git a/gcc/testsuite/ada/acats/tests/c8/c87b13a.ada b/gcc/testsuite/ada/acats/tests/c8/c87b13a.ada new file mode 100644 index 000000000..c46b6f093 --- /dev/null +++ b/gcc/testsuite/ada/acats/tests/c8/c87b13a.ada @@ -0,0 +1,71 @@ +-- C87B13A.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 OVERLOADING RESOLUTION USES THE RULE THAT: +-- +-- THE LOWER AND UPPER BOUNDS OF AN INDEX CONSTRAINT IN A CONSTRAINED +-- ARRAY TYPE DEFINITION MUST BE DISCRETE AND OF THE SAME TYPE. + +-- TRH 1 JULY 82 + +WITH REPORT; USE REPORT; + +PROCEDURE C87B13A IS + + TYPE CENTI IS DELTA 0.01 RANGE -1.0 .. 1.0; + + FUNCTION F1 (X : INTEGER) RETURN INTEGER IS + BEGIN + RETURN X; + END F1; + + FUNCTION F1 (X : INTEGER) RETURN CENTI IS + BEGIN + FAILED ("INDEX CONSTRAINT BOUNDS MUST BE DISCRETE AND " & + " OF THE SAME TYPE"); + RETURN 0.0; + END F1; + + FUNCTION F1 (X : INTEGER) RETURN FLOAT IS + BEGIN + FAILED ("INDEX CONSTRAINT BOUNDS MUST BE DISCRETE AND " & + " OF THE SAME TYPE"); + RETURN 1.0; + END F1; + +BEGIN + TEST ("C87B13A","OVERLOADED INDEX CONSTRAINTS IN " & + "CONSTRAINED ARRAY TYPE DEFINITIONS"); + + DECLARE + TYPE A1 IS ARRAY (F1 (1) .. F1 (1)) OF BOOLEAN; + TYPE A2 IS ARRAY (1 .. F1 (2)) OF BOOLEAN; + TYPE A3 IS ARRAY (F1 (1) .. 2) OF BOOLEAN; + + BEGIN + NULL; + END; + + RESULT; +END C87B13A; diff --git a/gcc/testsuite/ada/acats/tests/c8/c87b14a.ada b/gcc/testsuite/ada/acats/tests/c8/c87b14a.ada new file mode 100644 index 000000000..1ef05163e --- /dev/null +++ b/gcc/testsuite/ada/acats/tests/c8/c87b14a.ada @@ -0,0 +1,87 @@ +-- C87B14A.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 OVERLOADING RESOLUTION USES THE RULE THAT: +-- +-- IN SUBTYPE INDICATIONS WITH INDEX CONSTRAINTS, THE LOWER AND UPPER +-- BOUNDS MUST BE OF THE INDEX BASE TYPE. +-- +-- TEST (A): INDEX CONSTRAINTS WITH OVERLOADED FUNCTIONS. + +-- TRH 30 JUNE 82 + +WITH REPORT; USE REPORT; + +PROCEDURE C87B14A IS + + SUBTYPE WHOLE IS INTEGER RANGE 0 .. INTEGER'LAST; + SUBTYPE BASE10 IS INTEGER RANGE 0 .. 9; + TYPE LIST IS ARRAY (INTEGER RANGE <>) OF BOOLEAN; + TYPE GRID IS ARRAY (INTEGER RANGE <>, INTEGER RANGE <>) OF BOOLEAN; + + FUNCTION F1 RETURN WHOLE IS + BEGIN + RETURN 1; + END F1; + + FUNCTION F1 RETURN BOOLEAN IS + BEGIN + FAILED ("RESOLUTION INCORRECT - INDEX CONSTRAINTS " & + " IN SUBTYPE INDICATIONS"); + RETURN TRUE; + END F1; + + FUNCTION F2 RETURN BASE10 IS + BEGIN + RETURN 2; + END F2; + + FUNCTION F2 RETURN FLOAT IS + BEGIN + FAILED ("RESOLUTION INCORRECT - INDEX CONSTRAINTS " & + " IN SUBTYPE INDICATIONS"); + RETURN 2.0; + END F2; + +BEGIN + TEST ("C87B14A","OVERLOADED EXPRESSIONS IN INDEX CONSTRAINTS " & + "OF SUBTYPE INDICATIONS"); + + DECLARE + SUBTYPE LIST1 IS LIST (1 .. F1); + SUBTYPE LIST2 IS LIST (F1 .. 1); + SUBTYPE LIST3 IS LIST (F2 .. F2); + SUBTYPE LIST4 IS LIST (F1 .. F2); + + SUBTYPE GRID1 IS GRID (1 .. F1, F1 .. 1); + SUBTYPE GRID2 IS GRID (F1 .. 2, 2 .. F2); + SUBTYPE GRID3 IS GRID (F1 .. F1, F2 .. F2); + SUBTYPE GRID4 IS GRID (F1 .. F2, 1 .. 2); + + BEGIN + NULL; + END; + + RESULT; +END C87B14A; diff --git a/gcc/testsuite/ada/acats/tests/c8/c87b14b.ada b/gcc/testsuite/ada/acats/tests/c8/c87b14b.ada new file mode 100644 index 000000000..2d6a512fc --- /dev/null +++ b/gcc/testsuite/ada/acats/tests/c8/c87b14b.ada @@ -0,0 +1,90 @@ +-- C87B14B.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 OVERLOADING RESOLUTION USES THE RULE THAT: +-- +-- IN SUBTYPE INDICATIONS WITH INDEX CONSTRAINTS, THE LOWER AND UPPER +-- BOUNDS MUST BE OF THE INDEX BASE TYPE. +-- +-- TEST (B): INDEX CONSTRAINTS WITH OVERLOADED OPERATOR SYMBOLS. + +-- TRH 30 JUNE 82 + +WITH REPORT; USE REPORT; + +PROCEDURE C87B14B IS + + SUBTYPE CHAR IS CHARACTER; + SUBTYPE VAR IS CHAR RANGE 'X' .. 'Z'; + SUBTYPE NOTE IS CHAR RANGE 'A' .. 'G'; + TYPE LIST IS ARRAY (CHAR RANGE <>) OF CHAR; + TYPE GRID IS ARRAY (CHAR RANGE <>, CHAR RANGE <>) OF CHAR; + + FUNCTION "*" (X, Y : INTEGER) RETURN VAR IS + BEGIN + RETURN 'X'; + END "*"; + + FUNCTION "*" (X, Y : INTEGER) RETURN BOOLEAN IS + BEGIN + FAILED ("RESOLUTION INCORRECT - INDEX CONSTRAINTS " & + " IN SUBTYPE INDICATIONS"); + RETURN TRUE; + END "*"; + + FUNCTION "+" (X, Y : INTEGER) RETURN NOTE IS + BEGIN + RETURN 'A'; + END "+"; + + FUNCTION "+" (X, Y : INTEGER) RETURN FLOAT IS + BEGIN + FAILED ("RESOLUTION INCORRECT - INDEX CONSTRAINTS " & + " IN SUBTYPE INDICATIONS"); + RETURN 2.0; + END "+"; + +BEGIN + TEST ("C87B14B","OVERLOADED OPERATOR SYMBOLS IN INDEX " & + "CONSTRAINTS OF SUBTYPE INDICATIONS"); + + DECLARE + + SUBTYPE LIST1 IS LIST ('W' .. "*" (0, 0)); + SUBTYPE LIST2 IS LIST ("+" (0, 0) .. 'C'); + SUBTYPE LIST3 IS LIST ("+" (0, 0) .. "*" (0, 0)); + SUBTYPE LIST4 IS LIST ("*" (0, 0) .. "*" (0, 0)); + + SUBTYPE GRID1 IS GRID ('V' .. "*" (0, 0), "*" (0, 0) .. 'Y'); + SUBTYPE GRID2 IS GRID ("*" (0, 0) .. 'W', 'H' .. "+" (0, 0)); + SUBTYPE GRID3 IS GRID + ("*" (0, 0) .. "*" (0, 0), "+" (0, 0) .. "+" (0, 0)); + SUBTYPE GRID4 IS GRID ("+" (0, 0) .. "*" (0, 0),'L' .. 'N'); + + BEGIN + NULL; + END; + + RESULT; +END C87B14B; diff --git a/gcc/testsuite/ada/acats/tests/c8/c87b14c.ada b/gcc/testsuite/ada/acats/tests/c8/c87b14c.ada new file mode 100644 index 000000000..9bdb041c9 --- /dev/null +++ b/gcc/testsuite/ada/acats/tests/c8/c87b14c.ada @@ -0,0 +1,89 @@ +-- C87B14C.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 OVERLOADING RESOLUTION USES THE RULE THAT: +-- +-- IN SUBTYPE INDICATIONS WITH INDEX CONSTRAINTS, THE LOWER AND UPPER +-- BOUNDS MUST BE OF THE INDEX BASE TYPE. +-- +-- TEST (C): INDEX CONSTRAINTS WITH OVERLOADED INFIX OPERATORS. + +-- TRH 30 JUNE 82 + +WITH REPORT; USE REPORT; + +PROCEDURE C87B14C IS + + TYPE DAY IS (MON, TUE, WED, THU, FRI, SAT, SUN); + TYPE LIST IS ARRAY (DAY RANGE <>) OF BOOLEAN; + TYPE GRID IS ARRAY (DAY RANGE <>, DAY RANGE <>) OF BOOLEAN; + SUBTYPE WEEKEND IS DAY RANGE SAT .. SUN; + SUBTYPE WEEKDAY IS DAY RANGE MON .. FRI; + + FUNCTION "*" (X, Y : INTEGER) RETURN WEEKDAY IS + BEGIN + RETURN MON; + END "*"; + + FUNCTION "*" (X, Y : INTEGER) RETURN BOOLEAN IS + BEGIN + FAILED ("RESOLUTION INCORRECT - INDEX CONSTRAINTS " & + " IN SUBTYPE INDICATIONS"); + RETURN TRUE; + END "*"; + + FUNCTION "+" (X, Y : INTEGER) RETURN WEEKEND IS + BEGIN + RETURN SAT; + END "+"; + + FUNCTION "+" (X, Y : INTEGER) RETURN FLOAT IS + BEGIN + FAILED ("RESOLUTION INCORRECT - INDEX CONSTRAINTS " & + " IN SUBTYPE INDICATIONS"); + RETURN 2.0; + END "+"; + +BEGIN + TEST ("C87B14C","OVERLOADED EXPRESSIONS IN INDEX CONSTRAINTS " & + "OF SUBTYPE INDICATIONS"); + + DECLARE + SUBTYPE LIST1 IS LIST (WED .. (0 + 0)); + SUBTYPE LIST2 IS LIST ( 0 * 0 .. TUE); + SUBTYPE LIST3 IS LIST ((0 + 0) .. (0 + 0)); + SUBTYPE LIST4 IS LIST ((0 * 0) .. (0 + 0)); + + SUBTYPE GRID1 IS GRID (MON .. (0 * 0), (0 * 0) .. TUE); + SUBTYPE GRID2 IS GRID ((0 * 0) .. WED, FRI .. (0 + 0)); + SUBTYPE GRID3 IS GRID + ((0 * 0) .. (0 * 0), (0 + 0) .. (0 + 0)); + SUBTYPE GRID4 IS GRID ((0 * 0) .. (0 + 0), TUE .. THU); + + BEGIN + NULL; + END; + + RESULT; +END C87B14C; diff --git a/gcc/testsuite/ada/acats/tests/c8/c87b14d.ada b/gcc/testsuite/ada/acats/tests/c8/c87b14d.ada new file mode 100644 index 000000000..cf1c4d3df --- /dev/null +++ b/gcc/testsuite/ada/acats/tests/c8/c87b14d.ada @@ -0,0 +1,63 @@ +-- C87B14D.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 OVERLOADING RESOLUTION USES THE RULE THAT: +-- +-- IN SUBTYPE INDICATIONS WITH INDEX CONSTRAINTS, IF A BOUND IS OF +-- TYPE UNIVERSAL_INTEGER, IT IS IMPLICITLY CONVERTED TO THE +-- INDEX BASE TYPE. + +-- TRH 7 JULY 82 + +WITH REPORT; USE REPORT; + +PROCEDURE C87B14D IS + + TYPE WHOLE IS NEW INTEGER RANGE 0 .. INTEGER'LAST; + TYPE LIST IS ARRAY (WHOLE RANGE <>) OF BOOLEAN; + +BEGIN + TEST ("C87B14D","OVERLOADED EXPRESSIONS IN INDEX CONSTRAINTS " & + "OF SUBTYPE INDICATIONS WITH UNIVERSAL_INTEGER BOUNDS"); + + DECLARE + FUNCTION "+" (X, Y : WHOLE) RETURN WHOLE + RENAMES "*"; + + SUBTYPE LIST1 IS LIST (1 + 1 .. 1 + 1); + SUBTYPE LIST2 IS LIST (1 .. 3 + 3); + SUBTYPE LIST3 IS LIST (1 + 1 .. 2); + + BEGIN + IF LIST1'FIRST /= 1 OR LIST1'LAST /= 1 OR + LIST2'FIRST /= 1 OR LIST2'LAST /= 9 OR + LIST3'FIRST /= 1 OR LIST3'LAST /= 2 THEN + FAILED ("RESOLUTION INCORRECT - IMPLICIT CONVERSION " & + "OF UNIVERSAL_INTEGER TYPE TO INDEX CONSTRAINT " & + "BASE TYPE"); + END IF; + END; + + RESULT; +END C87B14D; diff --git a/gcc/testsuite/ada/acats/tests/c8/c87b15a.ada b/gcc/testsuite/ada/acats/tests/c8/c87b15a.ada new file mode 100644 index 000000000..92a14de89 --- /dev/null +++ b/gcc/testsuite/ada/acats/tests/c8/c87b15a.ada @@ -0,0 +1,108 @@ +-- C87B15A.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 OVERLOADING RESOLUTION USES THE RULE THAT: +-- +-- THE ARRAY ATTRIBUTES OF THE FORM: A'FIRST (N), A'LAST (N), +-- A'RANGE (N) AND A'LENGTH (N) MUST HAVE A PARAMETER (N) WHICH IS OF +-- THE TYPE UNIVERSAL_INTEGER. + +-- TRH 26 JULY 82 + +WITH REPORT; USE REPORT; + +PROCEDURE C87B15A IS + + FUNCTION "+" (X, Y : INTEGER) RETURN INTEGER + RENAMES STANDARD."*"; + + TYPE BOX IS ARRAY (0 .. 1, 3 .. 6, 5 .. 11) OF BOOLEAN; + B1 : BOX; + +BEGIN + TEST ("C87B15A","ARRAY ATTRIBUTES: FIRST (N), LAST (N), RANGE " & + "(N) AND LENGTH (N) TAKE UNIVERSAL_INTEGER OPERANDS"); + + IF BOX'FIRST (1 + 0) /= 0 THEN + FAILED ("ARRAY ATTRIBUTE OPERAND MUST BE OF TYPE " & + "UNIVERSAL_INTEGER - 1"); + END IF; + + IF B1'FIRST (1 + 1) /= 3 THEN + FAILED ("ARRAY ATTRIBUTE OPERAND MUST BE OF TYPE " & + "UNIVERSAL_INTEGER - 2"); + END IF; + + IF B1'FIRST (2 + 1) /= 5 THEN + FAILED ("ARRAY ATTRIBUTE OPERAND MUST BE OF TYPE " & + "UNIVERSAL_INTEGER - 3"); + END IF; + + IF BOX'LAST (0 + 1) /= 1 THEN + FAILED ("ARRAY ATTRIBUTE OPERAND MUST BE OF TYPE " & + "UNIVERSAL_INTEGER - 4"); + END IF; + + IF B1'LAST (1 + 1) /= 6 THEN + FAILED ("ARRAY ATTRIBUTE OPERAND MUST BE OF TYPE " & + "UNIVERSAL_INTEGER - 5"); + END IF; + + IF B1'LAST (1 + 2) /= 11 THEN + FAILED ("ARRAY ATTRIBUTE OPERAND MUST BE OF TYPE " & + "UNIVERSAL_INTEGER - 6"); + END IF; + + IF BOX'LENGTH (0 + 1) /= 2 THEN + FAILED ("ARRAY ATTRIBUTE OPERAND MUST BE OF TYPE " & + "UNIVERSAL_INTEGER - 7"); + END IF; + + IF B1'LENGTH (1 + 1) /= 4 THEN + FAILED ("ARRAY ATTRIBUTE OPERAND MUST BE OF TYPE " & + "UNIVERSAL_INTEGER - 8"); + END IF; + + IF B1'LENGTH (2 + 1) /= 7 THEN + FAILED ("ARRAY ATTRIBUTE OPERAND MUST BE OF TYPE " & + "UNIVERSAL_INTEGER - 9"); + END IF; + + IF 1 NOT IN BOX'RANGE (0 + 1) THEN + FAILED ("ARRAY ATTRIBUTE OPERAND MUST BE OF TYPE " & + "UNIVERSAL_INTEGER - 10"); + END IF; + + IF 4 NOT IN B1'RANGE (1 + 1) THEN + FAILED ("ARRAY ATTRIBUTE OPERAND MUST BE OF TYPE " & + "UNIVERSAL_INTEGER - 11"); + END IF; + + IF 9 NOT IN B1'RANGE (2 + 1) THEN + FAILED ("ARRAY ATTRIBUTE OPERAND MUST BE OF TYPE " & + "UNIVERSAL_INTEGER - 12"); + END IF; + + RESULT; +END C87B15A; diff --git a/gcc/testsuite/ada/acats/tests/c8/c87b16a.ada b/gcc/testsuite/ada/acats/tests/c8/c87b16a.ada new file mode 100644 index 000000000..307ca0e05 --- /dev/null +++ b/gcc/testsuite/ada/acats/tests/c8/c87b16a.ada @@ -0,0 +1,129 @@ +-- C87B16A.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 OVERLOADING RESOLUTION USES THE RULE THAT: +-- +-- FOR A DEFAULT RECORD COMPONENT, THE TYPE OF THE INITIALIZATION +-- EXPRESSION MUST MATCH THE COMPONENTS'S EXPLICIT TYPEMARK. +-- +-- THE FOUR KINDS OF EXPRESSIONS TESTED HERE ARE: +-- +-- (A): A CALL TO AN OVERLOADED FUNCTION. +-- (B): AN OVERLOADED OPERATOR SYMBOL. +-- (C): AN OVERLOADED (INFIX) OPERATOR. +-- (D): AN OVERLOADED ENUMERATION LITERAL. + +-- TRH 23 JUNE 82 + +WITH REPORT; USE REPORT; + +PROCEDURE C87B16A IS + + TYPE WHOLE IS NEW INTEGER RANGE 0..INTEGER'LAST; + TYPE CITRUS IS (LEMON, LIME, ORANGE); + TYPE HUE IS (RED, ORANGE, YELLOW); + + FUNCTION F1 (X, Y : INTEGER) RETURN INTEGER IS + BEGIN + RETURN -1; + END F1; + + FUNCTION F1 (X, Y : WHOLE) RETURN WHOLE IS + BEGIN + RETURN 0; + END F1; + + FUNCTION F1 (X, Y : INTEGER) RETURN HUE IS + BEGIN + RETURN ORANGE; + END F1; + + FUNCTION F1 (X, Y : INTEGER) RETURN CITRUS IS + BEGIN + RETURN ORANGE; + END F1; + +BEGIN + TEST ("C87B16A","OVERLOADED INITIALIZATION EXPRESSIONS" & + " IN DEFAULT RECORD COMPONENTS"); + DECLARE + + FUNCTION "-" (X, Y : INTEGER) RETURN INTEGER + RENAMES F1; + + FUNCTION "-" (X, Y : WHOLE) RETURN WHOLE + RENAMES F1; + + FUNCTION "-" (X, Y : INTEGER) RETURN HUE + RENAMES F1; + + FUNCTION "-" (X, Y : INTEGER) RETURN CITRUS + RENAMES F1; + + TYPE REC IS + RECORD + I1 : INTEGER := F1 (0, 0); + W1 : WHOLE := F1 (0, 0); + C1 : CITRUS := F1 (0, 0); + H1 : HUE := F1 (0, 0); + + I2 : INTEGER := "-" (0, 0); + W2 : WHOLE := "-" (0, 0); + C2 : CITRUS := "-" (0, 0); + H2 : HUE := "-" (0, 0); + + I3 : INTEGER := (0 - 0); + W3 : WHOLE := (0 - 0); + C3 : CITRUS := (0 - 0); + H3 : HUE := (0 - 0); + + C4 : CITRUS := ORANGE; + H4 : HUE := ORANGE; + END RECORD; + + R1 : REC; + + BEGIN + IF R1.I1 /= -1 OR R1.W1 /= 0 OR + CITRUS'POS (R1.C1) /= 2 OR HUE'POS (R1.H1) /= 1 THEN + FAILED ("(A): RESOLUTION INCORRECT - FUNCTION CALL"); + END IF; + + IF R1.I2 /= -1 OR R1.W2 /= 0 OR + CITRUS'POS (R1.C2) /= 2 OR HUE'POS (R1.H2) /= 1 THEN + FAILED ("(B): RESOLUTION INCORRECT - OPERATOR SYMBOL"); + END IF; + + IF R1.I3 /= -1 OR R1.W3 /= 0 OR + CITRUS'POS (R1.C3) /= 2 OR HUE'POS (R1.H3) /= 1 THEN + FAILED ("(C): RESOLUTION INCORRECT - INFIX OPERATOR"); + END IF; + + IF CITRUS'POS (R1.C4) /= 2 OR HUE'POS (R1.H4) /= 1 THEN + FAILED ("(D): RESOLUTION INCORRECT - ENUMERATION LITERAL"); + END IF; + END; + + RESULT; +END C87B16A; diff --git a/gcc/testsuite/ada/acats/tests/c8/c87b17a.ada b/gcc/testsuite/ada/acats/tests/c8/c87b17a.ada new file mode 100644 index 000000000..96405d631 --- /dev/null +++ b/gcc/testsuite/ada/acats/tests/c8/c87b17a.ada @@ -0,0 +1,130 @@ +-- C87B17A.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 OVERLOADING RESOLUTION USES THE RULE THAT: + +-- THE INITIALIZATION EXPRESSION FOR A DEFAULT DISCRIMINANT +-- IN A TYPE DECLARATION MUST MATCH THE DISCRIMINANT'S EXPLICIT +-- TYPEMARK. +-- +-- THE THREE KINDS OF TYPE DECLARATIONS TESTED HERE ARE: +-- +-- (A): RECORD TYPE. +-- (B): PRIVATE TYPE. +-- (C): INCOMPLETE RECORD TYPE. + +-- TRH 18 JUNE 82 + +WITH REPORT; USE REPORT; + +PROCEDURE C87B17A IS + + TYPE WHOLE IS NEW INTEGER RANGE 0..INTEGER'LAST; + TYPE CITRUS IS (LEMON, LIME, ORANGE); + TYPE HUE IS (RED, ORANGE, YELLOW); + + FUNCTION F1 (X, Y : INTEGER) RETURN INTEGER IS + BEGIN + RETURN -1; + END F1; + + FUNCTION F1 (X, Y : WHOLE) RETURN WHOLE IS + BEGIN + RETURN 0; + END F1; + + FUNCTION F1 (X, Y : INTEGER) RETURN HUE IS + BEGIN + RETURN ORANGE; + END F1; + + FUNCTION F1 (X, Y : INTEGER) RETURN CITRUS IS + BEGIN + RETURN ORANGE; + END F1; + +BEGIN + TEST ("C87B17A","OVERLOADED INITIALIZATION EXPRESSIONS" & + " IN DEFAULT DISCRIMINANTS"); + + DECLARE + + FUNCTION "+" (X, Y : INTEGER) RETURN INTEGER + RENAMES F1; + + FUNCTION "+" (X, Y : WHOLE) RETURN WHOLE + RENAMES F1; + + FUNCTION "+" (X, Y : INTEGER) RETURN HUE + RENAMES F1; + + FUNCTION "+" (X, Y : INTEGER) RETURN CITRUS + RENAMES F1; + + TYPE REC1 (I1 : INTEGER := 0 + 0; H1 : HUE := F1 (0, 0) ) IS + RECORD + NULL; + END RECORD; + + PACKAGE PVT IS + TYPE REC2 (H2 : HUE := ORANGE; W2 : WHOLE := 0 + 0 ) + IS PRIVATE; + PRIVATE + TYPE REC2 (H2 : HUE := ORANGE; W2 : WHOLE := 0 + 0 ) IS + RECORD + NULL; + END RECORD; + END PVT; + USE PVT; + + TYPE REC3 (C1 : CITRUS := ORANGE; W1 : WHOLE := "+" (0, 0)); + + TYPE LINK IS ACCESS REC3; + + TYPE REC3 (C1 : CITRUS := ORANGE; W1 : WHOLE := "+" (0, 0)) IS + RECORD + NULL; + END RECORD; + + R1 : REC1; + R2 : REC2; + R3 : REC3; + + BEGIN + IF R1.I1 /= -1 OR HUE'POS (R1.H1) /= 1 THEN + FAILED ("(A): RESOLUTION INCORRECT FOR RECORD TYPES"); + END IF; + + IF HUE'POS (R2.H2) /= 1 OR R2.W2 /= 0 THEN + FAILED ("(B): RESOLUTION INCORRECT FOR PRIVATE TYPES"); + END IF; + + IF CITRUS'POS (R3.C1) /= 2 OR R3.W1 /= 0 THEN + FAILED ("(C): RESOLUTION INCORRECT FOR INCOMPLETE" & + " RECORD TYPES"); + END IF; + END; + + RESULT; +END C87B17A; diff --git a/gcc/testsuite/ada/acats/tests/c8/c87b18a.ada b/gcc/testsuite/ada/acats/tests/c8/c87b18a.ada new file mode 100644 index 000000000..fdb2ad352 --- /dev/null +++ b/gcc/testsuite/ada/acats/tests/c8/c87b18a.ada @@ -0,0 +1,82 @@ +-- C87B18A.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 OVERLOADING RESOLUTION USES THE RULE THAT: +-- +-- THE TYPES OF THE EXPRESSIONS IN A DISCRIMINANT CONSTRAINT IN +-- A SUBTYPE INDICATION MUST MATCH THE DISCRIMINANT'S EXPLICIT +-- TYPEMARK. + +-- TRH 1 JULY 82 + +WITH REPORT; USE REPORT; + +PROCEDURE C87B18A IS + + ERR : BOOLEAN := FALSE; + + FUNCTION F1 RETURN INTEGER IS + BEGIN + RETURN 1; + END F1; + + FUNCTION F1 RETURN FLOAT IS + BEGIN + ERR := TRUE; + RETURN 0.0; + END F1; + + FUNCTION F2 RETURN BOOLEAN IS + BEGIN + RETURN TRUE; + END F2; + + FUNCTION F2 RETURN STRING IS + BEGIN + ERR := TRUE; + RETURN "STRING"; + END F2; + +BEGIN + TEST ("C87B18A","OVERLOADED EXPRESSIONS IN DISCRIMINANT " & + "CONSTRAINTS"); + + DECLARE + TYPE REC (X : INTEGER := 0; Y : BOOLEAN := TRUE) IS + RECORD + NULL; + END RECORD; + + R1 : REC (F1, F2); + R2 : REC (Y => F2, X => F1); + + BEGIN + IF ERR THEN + FAILED ("RESOLUTION INCORRECT - DISCRIMINANT " & + "CONSTRAINT MUST MATCH DISCRIMINANT TYPE"); + END IF; + END; + + RESULT; +END C87B18A; diff --git a/gcc/testsuite/ada/acats/tests/c8/c87b18b.ada b/gcc/testsuite/ada/acats/tests/c8/c87b18b.ada new file mode 100644 index 000000000..f0824b94b --- /dev/null +++ b/gcc/testsuite/ada/acats/tests/c8/c87b18b.ada @@ -0,0 +1,83 @@ +-- C87B18B.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 OVERLOADING RESOLUTION USES THE RULE THAT: +-- +-- THE EXPRESSION IN A NAMED OR POSITIONAL DISCRIMINANT ASSOCIATION +-- MUST MATCH THE TYPE OF THE CORRESPONDING DISCRIMINANT. + +-- TRH 9 AUG 82 +-- PWN 01/31/95 REMOVED INCONSISTENCIES WITH ADA 9X. + +WITH REPORT; USE REPORT; + +PROCEDURE C87B18B IS + + TYPE REC (W, X : CHARACTER; Y, Z : BOOLEAN) IS + RECORD + NULL; + END RECORD; + + TYPE FLAG IS (PASS, FAIL); + + GENERIC + TYPE T IS PRIVATE; + ARG : IN T; + STAT : IN FLAG; + FUNCTION F1 RETURN T; + + FUNCTION F1 RETURN T IS + BEGIN + IF STAT = FAIL THEN + FAILED ("DISCRIMINANT ASSOCIATION EXPRESSION MUST " & + "MATCH THE TYPE OF THE CORRESPONDING " & + "DISCRIMINANT"); + END IF; + RETURN ARG; + END F1; + + FUNCTION F IS NEW F1 (FLOAT, 2.0, FAIL); + FUNCTION F IS NEW F1 (INTEGER, 5, FAIL); + FUNCTION F IS NEW F1 (BOOLEAN, TRUE, FAIL); + FUNCTION F IS NEW F1 (CHARACTER, 'E', PASS); + + FUNCTION G IS NEW F1 (FLOAT, 2.0, FAIL); + FUNCTION G IS NEW F1 (INTEGER, 5, FAIL); + FUNCTION G IS NEW F1 (BOOLEAN, TRUE, PASS); + FUNCTION G IS NEW F1 (CHARACTER, 'E', FAIL); + +BEGIN + TEST ("C87B18B","OVERLOADED DISCRIMINANT ASSOCIATIONS"); + + DECLARE + SUBTYPE R1 IS REC (F, F, G, G); + SUBTYPE R2 IS REC (X => F, Y => G, Z => G, W => F); + SUBTYPE R3 IS REC (F, F, Z => G, Y => G); + + BEGIN + NULL; + END; + + RESULT; +END C87B18B; diff --git a/gcc/testsuite/ada/acats/tests/c8/c87b19a.ada b/gcc/testsuite/ada/acats/tests/c8/c87b19a.ada new file mode 100644 index 000000000..aa1960d19 --- /dev/null +++ b/gcc/testsuite/ada/acats/tests/c8/c87b19a.ada @@ -0,0 +1,110 @@ +-- C87B19A.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 OVERLOADING RESOLUTION USES THE RULE THAT: +-- +-- SIMPLE EXPRESSIONS AND RANGE BOUNDS OF VARIANT CHOICES MUST MATCH +-- THE TYPE OF THE DISCRIMINANT'S EXPLICIT TYPEMARK. + +--HISTORY: +-- DSJ 06/15/83 CREATED ORIGINAL TEST. +-- DHH 10/20/87 SHORTENED LINES CONTAINING MORE THAN 72 CHARACTERS. + +WITH REPORT; USE REPORT; + +PROCEDURE C87B19A IS + + TYPE COLOR IS (YELLOW, RED, BLUE, GREEN, BROWN); + TYPE SCHOOL IS (YALE, HARVARD, PRINCETON, BROWN, STANFORD); + TYPE COOK IS (BROIL, BAKE, BROWN, TOAST, FRY); + TYPE MIXED IS (GREEN, BROWN, YALE, BAKE, BLUE, FRY); + + RATING : INTEGER := 0; + + FUNCTION OK RETURN BOOLEAN IS + BEGIN + RATING := RATING + 1; + RETURN FALSE; + END OK; + + FUNCTION ERR RETURN BOOLEAN IS + BEGIN + FAILED ("VARIANT CHOICES MUST MATCH TYPE OF DISCRIMINANT"); + RETURN FALSE; + END ERR; + +BEGIN + TEST ("C87B19A","OVERLOADED EXPRESSIONS AND RANGE BOUNDS" & + " OF VARIANT CHOICES"); + DECLARE + + TYPE REC (X : MIXED := BROWN) IS + RECORD + CASE X IS + WHEN GREEN .. BROWN => NULL; + WHEN BLUE => NULL; + WHEN FRY => NULL; + WHEN YALE => NULL; + WHEN OTHERS => NULL; + END CASE; + END RECORD; + + R1 : REC (X => FRY); + R2 : REC (X => BLUE); + R3 : REC (X => BAKE); + R4 : REC (X => YALE); + R5 : REC (X => BROWN); + R6 : REC (X => GREEN); + + BEGIN + IF MIXED'POS(R1.X) /= 5 THEN + FAILED ("VARIANT CHOICES MUST MATCH TYPE OF " & + "DISCRIMINANT-R1"); + END IF; + IF MIXED'POS(R2.X) /= 4 THEN + FAILED ("VARIANT CHOICES MUST MATCH TYPE OF " & + "DISCRIMINANT-R2"); + END IF; + IF MIXED'POS(R3.X) /= 3 THEN + FAILED ("VARIANT CHOICES MUST MATCH TYPE OF " & + "DISCRIMINANT-R3"); + END IF; + IF MIXED'POS(R4.X) /= 2 THEN + FAILED ("VARIANT CHOICES MUST MATCH TYPE OF " & + "DISCRIMINANT-R4"); + END IF; + IF MIXED'POS(R5.X) /= 1 THEN + FAILED ("VARIANT CHOICES MUST MATCH TYPE OF " & + "DISCRIMINANT-R5"); + END IF; + IF MIXED'POS(R6.X) /= 0 THEN + FAILED ("VARIANT CHOICES MUST MATCH TYPE OF " & + "DISCRIMINANT-R6"); + END IF; + + END; + + RESULT; +END C87B19A; diff --git a/gcc/testsuite/ada/acats/tests/c8/c87b23a.ada b/gcc/testsuite/ada/acats/tests/c8/c87b23a.ada new file mode 100644 index 000000000..5cfa1d825 --- /dev/null +++ b/gcc/testsuite/ada/acats/tests/c8/c87b23a.ada @@ -0,0 +1,100 @@ +-- C87B23A.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 OVERLOADING RESOLUTION USES THE RULE THAT: +-- +-- FOR AN INDEXED COMPONENT OF AN ARRAY, THE PREFIX MUST BE +-- APPROPRIATE FOR AN ARRAY TYPE. EACH EXPRESSION FOR THE INDEXED +-- COMPONENT MUST BE OF THE TYPE OF THE CORRESPONDING INDEX AND +-- THERE MUST BE ONE SUCH EXPRESSION FOR EACH INDEX POSITION OF THE +-- ARRAY TYPE. + +-- TRH 15 SEPT 82 +-- DSJ 07 JUNE 83 + +WITH REPORT; USE REPORT; + +PROCEDURE C87B23A IS + + SUBTYPE CHAR IS CHARACTER; + TYPE GRADE IS (A, B, C, D, F); + TYPE NOTE IS (A, B, C, D, E, F, G); + TYPE INT IS NEW INTEGER; + TYPE POS IS NEW INTEGER RANGE 1 .. INTEGER'LAST; + TYPE NAT IS NEW POS; + TYPE BOOL IS NEW BOOLEAN; + TYPE BIT IS NEW BOOL; + TYPE LIT IS (FALSE, TRUE); + TYPE FLAG IS (PASS, FAIL); + + TYPE NUM2 IS DIGITS(2); + TYPE NUM3 IS DIGITS(2); + TYPE NUM4 IS DIGITS(2); + + TYPE A1 IS ARRAY (POS'(1)..5, NOTE'(A)..D, BOOL'(FALSE)..TRUE) + OF FLOAT; + TYPE A2 IS ARRAY (INT'(1)..5, NOTE'(A)..D, BIT'(FALSE)..TRUE) + OF NUM2; + TYPE A3 IS ARRAY (POS'(1)..5, GRADE'(A)..D, BOOL'(FALSE)..TRUE) + OF NUM3; + TYPE A4 IS ARRAY (NAT'(1)..5, NOTE'(A)..D, LIT'(FALSE)..TRUE) + OF NUM4; + + OBJ1 : A1 := (OTHERS => (OTHERS => (OTHERS => 0.0))); + OBJ2 : A2 := (OTHERS => (OTHERS => (OTHERS => 0.0))); + OBJ3 : A3 := (OTHERS => (OTHERS => (OTHERS => 0.0))); + OBJ4 : A4 := (OTHERS => (OTHERS => (OTHERS => 0.0))); + + GENERIC + TYPE T IS PRIVATE; + ARG : IN T; + STAT : IN FLAG; + FUNCTION F1 RETURN T; + + FUNCTION F1 RETURN T IS + BEGIN + IF STAT = FAIL THEN + FAILED ("PREFIX OR INDEX IS NOT APPROPRIATE FOR" & + " INDEXED COMPONENT"); + END IF; + RETURN ARG; + END F1; + + FUNCTION A IS NEW F1 (A1, OBJ1, PASS); + FUNCTION A IS NEW F1 (A2, OBJ2, FAIL); + FUNCTION A IS NEW F1 (A3, OBJ3, FAIL); + FUNCTION A IS NEW F1 (A4, OBJ4, FAIL); + +BEGIN + TEST ("C87B23A","OVERLOADED ARRAY INDEXES"); + + DECLARE + F1 : FLOAT := A (3, C, TRUE); + + BEGIN + NULL; + END; + + RESULT; +END C87B23A; diff --git a/gcc/testsuite/ada/acats/tests/c8/c87b24a.ada b/gcc/testsuite/ada/acats/tests/c8/c87b24a.ada new file mode 100644 index 000000000..abfaad633 --- /dev/null +++ b/gcc/testsuite/ada/acats/tests/c8/c87b24a.ada @@ -0,0 +1,79 @@ +-- C87B24A.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 OVERLOADING RESOLUTION USES THE RULE THAT: + +-- THE PREFIX OF A SLICE MUST BE APPROPRIATE FOR A ONE DIMENSIONAL +-- ARRAY TYPE. + +-- TRH 26 JULY 82 + +WITH REPORT; USE REPORT; + +PROCEDURE C87B24A IS + + TYPE LIST IS ARRAY (1 .. 5) OF INTEGER; + TYPE GRID IS ARRAY (1 .. 5, 1 .. 5) OF INTEGER; + TYPE CUBE IS ARRAY (1 .. 5, 1 .. 5, 1 .. 5) OF INTEGER; + TYPE HYPE IS ARRAY (1 .. 5, 1 .. 5, 1 .. 5, 1 .. 5) OF INTEGER; + TYPE FLAG IS (PASS, FAIL); + + L : LIST := (1 .. 5 => 0); + G : GRID := (1 .. 5 => (1 .. 5 => 0)); + C : CUBE := (1 .. 5 => (1 .. 5 => (1 .. 5 => 0))); + H : HYPE := (1 .. 5 => (1 .. 5 => (1 .. 5 => (1 .. 5 => 0)))); + + GENERIC + TYPE T IS PRIVATE; + ARG : IN T; + STAT : IN FLAG; + FUNCTION F1 RETURN T; + + FUNCTION F1 RETURN T IS + BEGIN + IF STAT = FAIL THEN + FAILED ("SLICE PREFIX MUST BE APPROPRIATE FOR ONE " & + "DIMENSIONAL ARRAY"); + END IF; + RETURN ARG; + END F1; + + FUNCTION F2 IS NEW F1 (LIST, L, PASS); + FUNCTION F2 IS NEW F1 (GRID, G, FAIL); + FUNCTION F2 IS NEW F1 (CUBE, C, FAIL); + FUNCTION F2 IS NEW F1 (HYPE, H, FAIL); + +BEGIN + TEST ("C87B24A","OVERLOADED PREFIX FOR SLICE RESOLVED TO " & + "ONE DIMENSIONAL ARRAY TYPE"); + + DECLARE + S1 : INTEGER; + + BEGIN + S1 := F2 (2 .. 3)(2); + END; + + RESULT; +END C87B24A; diff --git a/gcc/testsuite/ada/acats/tests/c8/c87b24b.ada b/gcc/testsuite/ada/acats/tests/c8/c87b24b.ada new file mode 100644 index 000000000..537cf9b48 --- /dev/null +++ b/gcc/testsuite/ada/acats/tests/c8/c87b24b.ada @@ -0,0 +1,98 @@ +-- C87B24B.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 OVERLOADING RESOLUTION USES THE RULE THAT: + +-- THE RANGE BOUNDS FOR A SLICE MUST BE DISCRETE AND OF THE SAME BASE +-- TYPE AS THE ARRAY INDEX. + +-- TRH 15 JULY 82 + +WITH REPORT; USE REPORT; + +PROCEDURE C87B24B IS + + TYPE PIECE IS ARRAY (INTEGER RANGE <>) OF INTEGER; + + PI : PIECE (1 .. 8) := (3, 1, 4, 1, 5, 9, 2, 6); + S1 : PIECE (1 .. 3); + S2 : PIECE (4 .. 8); + ERR : BOOLEAN := FALSE; + + FUNCTION F1 (X : INTEGER) RETURN INTEGER IS + BEGIN + RETURN X; + END F1; + + FUNCTION F1 (X : INTEGER) RETURN FLOAT IS + BEGIN + ERR := TRUE; + RETURN 0.0; + END F1; + + FUNCTION F2 (X : INTEGER) RETURN INTEGER IS + BEGIN + RETURN X; + END F2; + + FUNCTION F2 (X :INTEGER) RETURN CHARACTER IS + BEGIN + ERR := TRUE; + RETURN 'A'; + END F2; + +BEGIN + TEST ("C87B24B","OVERLOADING RESOLUTION OF RANGE " & + "CONSTRAINTS FOR SLICES"); + + DECLARE + FUNCTION "+" (X : INTEGER) RETURN INTEGER + RENAMES F1; + + FUNCTION "+" (X : INTEGER) RETURN FLOAT + RENAMES F1; + + FUNCTION "-" (X : INTEGER) RETURN INTEGER + RENAMES F2; + + FUNCTION "-" (X : INTEGER) RETURN CHARACTER + RENAMES F2; + + BEGIN + S1 := PI ("+" (3) .. "-" (5)); + S1 := PI (F2 (2) .. "+" (4)); + S1 := PI ("-" (6) .. F1 (8)); + S1 := PI (F2 (1) .. F2 (3)); + S2 := PI (F2 (4) .. F1 (8)); + S2 := PI (2 .. "+" (6)); + S2 := PI (F1 (1) .. 5); + S2 := PI ("+" (3) .. "+" (7)); + + IF ERR THEN + FAILED (" OVERLOADING RESOLUTION INCORRECT FOR SLICES"); + END IF; + END; + + RESULT; +END C87B24B; diff --git a/gcc/testsuite/ada/acats/tests/c8/c87b26b.ada b/gcc/testsuite/ada/acats/tests/c8/c87b26b.ada new file mode 100644 index 000000000..41f6ca4f5 --- /dev/null +++ b/gcc/testsuite/ada/acats/tests/c8/c87b26b.ada @@ -0,0 +1,149 @@ +-- C87B26B.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 'ADDRESS, 'CONSTRAINED, 'SIZE, AND 'STORAGE_SIZE MAY BE +-- USED WITH THE DESIGNATED OBJECTS OF ACCESS VALUES RETURNED FROM +-- OVERLOADED FUNCTIONS, AND THAT EXPLICIT DEREFERENCING IS USED BY +-- OVERLOADING RESOLUTION TO RESOLVE THE PREFIXES OF THE ATTRIBUTES. + +-- DSJ 22 JUN 83 +-- JBG 11/22/83 +-- JBG 4/23/84 +-- JBG 5/25/85 + +WITH REPORT; WITH SYSTEM; +USE REPORT; USE SYSTEM; + +PROCEDURE C87B26B IS + + TYPE REC (D : INTEGER) IS + RECORD + C1, C2 : INTEGER; + END RECORD; + TYPE P_REC IS ACCESS REC; + + P_REC_OBJECT : P_REC := NEW REC'(1,1,1); + + TYPE BIG_INT IS RANGE 0..SYSTEM.MAX_INT; + TASK TYPE TASK_TYPE IS + -- NOTHING AT ALL + END TASK_TYPE; + + TYPE P_TASK IS ACCESS TASK_TYPE; + + P_TASK_OBJECT : P_TASK; + + TASK BODY TASK_TYPE IS + BEGIN + NULL; + END TASK_TYPE; + + ------------------------------------------------------------ + + FUNCTION F RETURN REC IS + BEGIN + RETURN (0,0,0); + END F; + + FUNCTION F RETURN P_REC IS + BEGIN + RETURN P_REC_OBJECT; + END F; + + ------------------------------------------------------------ + + FUNCTION G RETURN TASK_TYPE IS + NEW_TASK : TASK_TYPE; + BEGIN + RETURN NEW_TASK; + END G; + + FUNCTION G RETURN P_TASK IS + BEGIN + RETURN P_TASK_OBJECT; + END G; + + ------------------------------------------------------------ + +BEGIN + + TEST("C87B26B","CHECK THAT EXPLICIT DEREFERENCING IN AN " & + "ATTRIBUTE PREFIX IS USED IN OVERLOADING RESOLUTION " & + "WITH 'ADDRESS, 'CONSTRAINED, 'SIZE, AND 'STORAGE_SIZE"); + + DECLARE + + A : ADDRESS; -- FOR 'ADDRESS OF RECORD + B : BOOLEAN; -- FOR 'CONSTRAINED OF RECORD + C : INTEGER; -- FOR 'SIZE OF RECORD + D : ADDRESS; -- FOR 'ADDRESS OF TASK + E : BIG_INT; -- FOR 'STORAGE_SIZE OF TASK + + BEGIN + + P_TASK_OBJECT := NEW TASK_TYPE; + A := F.ALL'ADDRESS; + B := F.ALL'CONSTRAINED; + C := F.ALL'SIZE; + D := G.ALL'ADDRESS; + E := G.ALL'STORAGE_SIZE; + + IF A /= P_REC_OBJECT.ALL'ADDRESS THEN + FAILED("INCORRECT RESOLUTION FOR 'ADDRESS - REC"); + END IF; + + IF B /= P_REC_OBJECT.ALL'CONSTRAINED THEN + FAILED("INCORRECT RESOLUTION FOR 'CONSTRAINED"); + END IF; + + IF C /= P_REC_OBJECT.ALL'SIZE THEN + FAILED("INCORRECT RESOLUTION FOR 'SIZE"); + END IF; + + IF D /= P_TASK_OBJECT.ALL'ADDRESS THEN + FAILED("INCORRECT RESOLUTION FOR 'ADDRESS - TASK"); + END IF; + + IF E /= P_TASK_OBJECT.ALL'STORAGE_SIZE THEN + FAILED("INCORRECT RESOLUTION FOR 'STORAGE_SIZE"); + END IF; + + IF A = P_REC_OBJECT'ADDRESS THEN + FAILED("INCORRECT DEREFERENCING FOR 'ADDRESS - REC"); + END IF; + + IF C = P_REC_OBJECT'SIZE AND C /= P_REC_OBJECT.ALL'SIZE THEN + FAILED("INCORRECT DEREFERENCING FOR 'SIZE"); + END IF; + + IF D = P_TASK_OBJECT'ADDRESS THEN + FAILED("INCORRECT DEREFERENCING FOR 'ADDRESS - TASK"); + END IF; + + + END; + + RESULT; + +END C87B26B; diff --git a/gcc/testsuite/ada/acats/tests/c8/c87b27a.ada b/gcc/testsuite/ada/acats/tests/c8/c87b27a.ada new file mode 100644 index 000000000..4b99792cd --- /dev/null +++ b/gcc/testsuite/ada/acats/tests/c8/c87b27a.ada @@ -0,0 +1,80 @@ +-- C87B27A.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 OVERLOADING RESOLUTION USES THE RULE THAT: +-- +-- THE TYPE OF A STRING LITERAL MUST BE DETERMINED FROM THE FACT +-- THAT A STRING LITERAL IS A VALUE OF A ONE DIMENSIONAL ARRAY OF +-- CHARACTER COMPONENTS. + +-- TRH 18 AUG 82 +-- DSJ 07 JUN 83 + +WITH REPORT; USE REPORT; + +PROCEDURE C87B27A IS + + TYPE ENUMLIT IS (A, B, C, D, E, F); + TYPE NEW_CHAR IS NEW CHARACTER RANGE 'G' .. 'Z'; + TYPE CHARS3 IS ('G','H','I','K','M','N','P','R','S','T'); + TYPE CHARS4 IS ('S','T','R','I','N','G','Z','A','P'); + TYPE NEW_STR IS ARRAY (A .. F) OF NEW_CHAR; + TYPE STRING3 IS ARRAY (11..16) OF CHARS3; + TYPE STRING4 IS ARRAY (21..26) OF CHARS4; + TYPE ENUM_VEC IS ARRAY (1 .. 6) OF ENUMLIT; + TYPE CHAR_GRID IS ARRAY (D .. F, 1 .. 3) OF NEW_CHAR; + TYPE STR_LIST IS ARRAY (1 .. 6) OF STRING (1 .. 1); + ERR : BOOLEAN := FALSE; + + PROCEDURE P (X : NEW_STR) IS + BEGIN + NULL; + END P; + + PROCEDURE P (X : ENUM_VEC) IS + BEGIN + ERR := TRUE; + END P; + + PROCEDURE P (X : CHAR_GRID) IS + BEGIN + ERR := TRUE; + END P; + + PROCEDURE P (X : STR_LIST) IS + BEGIN + ERR := TRUE; + END P; + +BEGIN + TEST ("C87B27A","OVERLOADING RESOLUTION OF STRING LITERALS"); + + P ("STRING"); + + IF ERR THEN + FAILED ("RESOLUTION INCORRECT FOR STRING LITERALS"); + END IF; + + RESULT; +END C87B27A; diff --git a/gcc/testsuite/ada/acats/tests/c8/c87b28a.ada b/gcc/testsuite/ada/acats/tests/c8/c87b28a.ada new file mode 100644 index 000000000..dfde694bb --- /dev/null +++ b/gcc/testsuite/ada/acats/tests/c8/c87b28a.ada @@ -0,0 +1,71 @@ +-- C87B28A.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 OVERLOADING RESOLUTION USES THE RULE THAT: +-- +-- THE TYPE OF THE LITERAL "NULL" MUST BE DETERMINED FROM THE FACT +-- THAT "NULL" IS A VALUE OF AN ACCESS TYPE. + +-- TRH 13 AUG 82 +-- JRK 2/2/84 + +WITH REPORT; USE REPORT; + +PROCEDURE C87B28A IS + + ERR : BOOLEAN := FALSE; + + TYPE A2 IS ACCESS BOOLEAN; + TYPE A3 IS ACCESS INTEGER; + TYPE A1 IS ACCESS A2; + + FUNCTION F RETURN A1 IS + BEGIN + RETURN NEW A2; + END F; + + FUNCTION F RETURN A2 IS + BEGIN + ERR := TRUE; + RETURN NEW BOOLEAN; + END F; + + FUNCTION F RETURN A3 IS + BEGIN + ERR := TRUE; + RETURN (NEW INTEGER); + END F; + +BEGIN + TEST ("C87B28A", "OVERLOADING OF THE ACCESS TYPE LITERAL 'NULL'"); + + F.ALL := NULL; + + IF ERR THEN + FAILED ("RESOLUTION INCORRECT FOR THE ACCESS TYPE LITERAL " & + "'NULL'"); + END IF; + + RESULT; +END C87B28A; diff --git a/gcc/testsuite/ada/acats/tests/c8/c87b29a.ada b/gcc/testsuite/ada/acats/tests/c8/c87b29a.ada new file mode 100644 index 000000000..594f71987 --- /dev/null +++ b/gcc/testsuite/ada/acats/tests/c8/c87b29a.ada @@ -0,0 +1,72 @@ +-- C87B29A.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 OVERLOADING RESOLUTION USES THE RULE THAT: +-- +-- AGGREGATES CONTAINING A SINGLE COMPONENT ASSOCIATION MUST +-- USE ONLY NAMED NOTATION. + +-- TRH 4 AUG 82 + +WITH REPORT; USE REPORT; + +PROCEDURE C87B29A IS + + TYPE VECTOR IS ARRAY (1 .. 1) OF INTEGER; + + TYPE REC IS + RECORD + X : INTEGER; + END RECORD; + + ERR : BOOLEAN := FALSE; + + PROCEDURE P1 (X : INTEGER) IS + BEGIN + NULL; + END P1; + + PROCEDURE P1 (X : VECTOR) IS + BEGIN + ERR := TRUE; + END P1; + + PROCEDURE P1 (X : REC) IS + BEGIN + ERR := TRUE; + END P1; + +BEGIN + TEST ("C87B29A","AGGREGATES CONTAINING A SINGLE COMPONENT " & + "ASSOCIATION MUST USE NAMED NOTATION"); + + P1 ( (0) ); -- INTEGER PARAMETER, NOT AN AGGREGATE PARAMETER + + IF ERR THEN + FAILED ("RESOLUTION INCORRECT - AGGREGATES WITH A SINGLE " & + "COMPONENT ASSOCIATION MUST USE NAMED NOTATION"); + END IF; + + RESULT; +END C87B29A; diff --git a/gcc/testsuite/ada/acats/tests/c8/c87b30a.ada b/gcc/testsuite/ada/acats/tests/c8/c87b30a.ada new file mode 100644 index 000000000..da574513e --- /dev/null +++ b/gcc/testsuite/ada/acats/tests/c8/c87b30a.ada @@ -0,0 +1,84 @@ +-- C87B30A.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 OVERLOADING RESOLUTION USES THE RULE THAT: +-- +-- THE EXPRESSION OF A COMPONENT ASSOCIATION MUST MATCH THE TYPE OF THE +-- ASSOCIATED RECORD COMPONENT. + +-- TRH 9 AUG 82 +-- PWN 01/31/95 REMOVED INCONSISTENCIES WITH ADA 9X. + +WITH REPORT; USE REPORT; + +PROCEDURE C87B30A IS + + TYPE REC IS + RECORD + W, X : FLOAT; + Y, Z : INTEGER; + END RECORD; + + TYPE FLAG IS (PASS, FAIL); + + GENERIC + TYPE T IS PRIVATE; + ARG : IN T; + STAT : IN FLAG; + FUNCTION F1 RETURN T; + + FUNCTION F1 RETURN T IS + BEGIN + IF STAT = FAIL THEN + FAILED ("COMPONENT ASSOCIATION EXPRESSION MUST MATCH " & + "RECORD COMPONENT TYPE"); + END IF; + RETURN ARG; + END F1; + + FUNCTION F IS NEW F1 (FLOAT, 2.0, PASS); + FUNCTION F IS NEW F1 (INTEGER, 5, FAIL); + FUNCTION F IS NEW F1 (BOOLEAN, TRUE, FAIL); + FUNCTION F IS NEW F1 (CHARACTER, 'E', FAIL); + + FUNCTION G IS NEW F1 (FLOAT, 2.0, FAIL); + FUNCTION G IS NEW F1 (INTEGER, 5, PASS); + FUNCTION G IS NEW F1 (BOOLEAN, TRUE, FAIL); + FUNCTION G IS NEW F1 (CHARACTER, 'E', FAIL); + +BEGIN + TEST ("C87B30A","OVERLOADED EXPRESSIONS IN RECORD AGGREGATE " & + "COMPONENT ASSOCIATIONS"); + + DECLARE + R1 : REC := (F, F, G, G); + R2 : REC := (X => F, Y => G, Z => G, W => F); + R3 : REC := (F, F, Z => G, Y => G); + + BEGIN + NULL; + END; + + RESULT; +END C87B30A; diff --git a/gcc/testsuite/ada/acats/tests/c8/c87b31a.ada b/gcc/testsuite/ada/acats/tests/c8/c87b31a.ada new file mode 100644 index 000000000..7aebd41dd --- /dev/null +++ b/gcc/testsuite/ada/acats/tests/c8/c87b31a.ada @@ -0,0 +1,137 @@ +-- C87B31A.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 OVERLOADING RESOLUTION USES THE RULE THAT: +-- +-- IF THE TYPE OF AN AGGREGATE IS A ONE-DIMENSIONAL ARRAY TYPE +-- THEN EACH CHOICE MUST SPECIFY VALUES OF THE INDEX TYPE, AND +-- THE EXPRESSION OF EACH COMPONENT ASSOCIATION MUST BE OF THE +-- COMPONENT TYPE. + +-- TRH 8 AUG 82 +-- DSJ 15 JUN 83 +-- JRK 2 FEB 84 +-- JBG 4/23/84 + +WITH REPORT; USE REPORT; + +PROCEDURE C87B31A IS + + TYPE LETTER IS NEW CHARACTER RANGE 'A' .. 'Z'; + TYPE NOTE IS (A, B, C, D, E, F, G, H); + TYPE STR IS NEW STRING (1 .. 1); + TYPE BIT IS NEW BOOLEAN; + TYPE YES IS NEW BOOLEAN RANGE TRUE .. TRUE; + TYPE NO IS NEW BOOLEAN RANGE FALSE .. FALSE; + TYPE BOOLEAN IS (FALSE, TRUE); + TYPE LIST IS ARRAY (CHARACTER RANGE <>) OF BIT; + TYPE FLAG IS (PASS, FAIL); + + SUBTYPE LIST_A IS LIST('A'..'A'); + SUBTYPE LIST_E IS LIST('E'..'E'); + SUBTYPE LIST_AE IS LIST('A'..'E'); + + GENERIC + TYPE T IS PRIVATE; + ARG : IN T; + STAT : IN FLAG; + FUNCTION F1 RETURN T; + + FUNCTION F1 RETURN T IS + BEGIN + IF STAT = FAIL THEN + FAILED ("RESOLUTION INCORRECT FOR EXPRESSIONS " & + "IN ARRAY AGGREGATES"); + END IF; + RETURN ARG; + END F1; + + FUNCTION F IS NEW F1 (BOOLEAN, FALSE, FAIL); + FUNCTION F IS NEW F1 (YES, TRUE, FAIL); + FUNCTION F IS NEW F1 (NO, FALSE, FAIL); + FUNCTION F IS NEW F1 (BIT, TRUE, PASS); + + FUNCTION G IS NEW F1 (CHARACTER, 'A', PASS); + FUNCTION G IS NEW F1 (LETTER, 'A', FAIL); + FUNCTION G IS NEW F1 (STR, "A", FAIL); + + FUNCTION H IS NEW F1 (CHARACTER, 'E', PASS); + FUNCTION H IS NEW F1 (LETTER, 'E', FAIL); + FUNCTION H IS NEW F1 (STR, "E", FAIL); + +BEGIN + TEST ("C87B31A", "OVERLOADED EXPRESSIONS IN ARRAY AGGREGATES"); + + DECLARE + L1, L2 : LIST_A := (OTHERS => FALSE); + L3, L4 : LIST_E := (OTHERS => FALSE); + L5, L6 : LIST_AE := (OTHERS => FALSE); + L7, L8 : LIST_AE := (OTHERS => FALSE); + + BEGIN + L1 := ('A' => F); + L2 := ( G => F); + L3 := ('E' => F); + L4 := ( H => F); + L5 := ('A'..'E' => F); + L6 := (F,F,F,F,F); + L7 := (F,F,F, OTHERS => F); + L8 := LIST_AE'('E' => F, 'B' => F, OTHERS => F); + + IF L1 /= LIST_A'(OTHERS => TRUE) THEN + FAILED ("RESOLUTION INCORRECT FOR OVERLOADED" & + " EXPRESSIONS IN ARRAY AGGREGATES - L1"); + END IF; + IF L2 /= LIST_A'(OTHERS => TRUE) THEN + FAILED ("RESOLUTION INCORRECT FOR OVERLOADED" & + " EXPRESSIONS IN ARRAY AGGREGATES - L2"); + END IF; + IF L3 /= LIST_E'(OTHERS => TRUE) THEN + FAILED ("RESOLUTION INCORRECT FOR OVERLOADED" & + " EXPRESSIONS IN ARRAY AGGREGATES - L3"); + END IF; + IF L4 /= LIST_E'(OTHERS => TRUE) THEN + FAILED ("RESOLUTION INCORRECT FOR OVERLOADED" & + " EXPRESSIONS IN ARRAY AGGREGATES - L4"); + END IF; + IF L5 /= LIST_AE'(OTHERS => TRUE) THEN + FAILED ("RESOLUTION INCORRECT FOR OVERLOADED" & + " EXPRESSIONS IN ARRAY AGGREGATES - L5"); + END IF; + IF L6 /= LIST_AE'(OTHERS => TRUE) THEN + FAILED ("RESOLUTION INCORRECT FOR OVERLOADED" & + " EXPRESSIONS IN ARRAY AGGREGATES - L6"); + END IF; + IF L7 /= LIST_AE'(OTHERS => TRUE) THEN + FAILED ("RESOLUTION INCORRECT FOR OVERLOADED" & + " EXPRESSIONS IN ARRAY AGGREGATES - L7"); + END IF; + IF L8 /= LIST_AE'(OTHERS => TRUE) THEN + FAILED ("RESOLUTION INCORRECT FOR OVERLOADED" & + " EXPRESSIONS IN ARRAY AGGREGATES - L8"); + END IF; + END; + + RESULT; +END C87B31A; diff --git a/gcc/testsuite/ada/acats/tests/c8/c87b32a.ada b/gcc/testsuite/ada/acats/tests/c8/c87b32a.ada new file mode 100644 index 000000000..1a31f113d --- /dev/null +++ b/gcc/testsuite/ada/acats/tests/c8/c87b32a.ada @@ -0,0 +1,199 @@ +-- C87B32A.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 OVERLOADING RESOLUTION USES THE FOLLOWING RULES: + +-- FOR ATTRIBUTES OF THE FORM: T'SUCC (X), T'PRED (X), T'POS (X), +-- AND T'IMAGE (X) , THE OPERAND X MUST BE OF TYPE T. +-- +-- FOR THE ATTRIBUTE OF THE FORM T'VAL (X), THE OPERAND X MUST BE +-- OF AN INTEGER TYPE. +-- +-- FOR THE ATTRIBUTE OF THE FORM T'VALUE (X), THE OPERAND X MUST +-- BE OF THE PREDEFINED TYPE STRING. + +-- TRH 13 SEPT 82 +-- JRK 12 JAN 84 + +WITH REPORT; USE REPORT; + +PROCEDURE C87B32A IS + + TYPE COLOR IS (BROWN, RED, WHITE); + TYPE SCHOOL IS (HARVARD, BROWN, YALE); + TYPE COOK IS (SIMMER, SAUTE, BROWN, BOIL); + TYPE SUGAR IS (DEXTROSE, CANE, GLUCOSE, BROWN); + TYPE WHOLE IS NEW INTEGER RANGE 0 .. INTEGER'LAST; + TYPE LIT_CHAR IS ('+', '-', '0', '1', '2', '3', '4', '5', '6', '7', + '8', '9'); + TYPE LIT_STRING IS ARRAY (POSITIVE RANGE <>) OF LIT_CHAR; + + FUNCTION "+" (X, Y : WHOLE) RETURN WHOLE + RENAMES "*"; + + FUNCTION F1 RETURN STRING IS + BEGIN + RETURN "+10"; + END F1; + + FUNCTION F1 RETURN LIT_STRING IS + BEGIN + FAILED ("THE VALUE ATTRIBUTE TAKES A PREDEFINED STRING " & + "OPERAND"); + RETURN "+3"; + END F1; + + FUNCTION F1 RETURN CHARACTER IS + BEGIN + FAILED ("THE VALUE ATTRIBUTE TAKES A STRING OPERAND"); + RETURN '2'; + END F1; + + FUNCTION F2 (X : INTEGER) RETURN FLOAT IS + BEGIN + FAILED ("THE VAL ATTRIBUTE TAKES AN INTEGER TYPE OPERAND"); + RETURN 0.0; + END F2; + + FUNCTION F2 (X : INTEGER := 1) RETURN INTEGER IS + BEGIN + RETURN X; + END F2; + +BEGIN + TEST ("C87B32A","OVERLOADED OPERANDS FOR THE ATTRIBUTES " & + "T'PRED, T'SUCC, T'POS, T'VAL, T'IMAGE AND T'VALUE"); + + IF COLOR'POS (BROWN) /= 0 THEN + FAILED ("RESOLUTION INCORRECT FOR OPERANDS OF THE ATTRIBUTES" & + " PRED, SUCC, VAL, POS, IMAGE AND VALUE - 1"); + END IF; + + IF SCHOOL'POS (BROWN) /= 1 THEN + FAILED ("RESOLUTION INCORRECT FOR OPERANDS OF THE ATTRIBUTES" & + " PRED, SUCC, VAL, POS, IMAGE AND VALUE - 2"); + END IF; + + IF COOK'POS (BROWN) /= 2 THEN + FAILED ("RESOLUTION INCORRECT FOR OPERANDS OF THE ATTRIBUTES" & + " PRED, SUCC, VAL, POS, IMAGE AND VALUE - 3"); + END IF; + + IF SUGAR'POS (BROWN) /= 3 THEN + FAILED ("RESOLUTION INCORRECT FOR OPERANDS OF THE ATTRIBUTES" & + " PRED, SUCC, VAL, POS, IMAGE AND VALUE - 4"); + END IF; + + IF SCHOOL'PRED (BROWN) /= HARVARD THEN + FAILED ("RESOLUTION INCORRECT FOR OPERANDS OF THE ATTRIBUTES" & + " PRED, SUCC, VAL, POS, IMAGE AND VALUE - 5"); + END IF; + + IF COOK'PRED (BROWN) /= SAUTE THEN + FAILED ("RESOLUTION INCORRECT FOR OPERANDS OF THE ATTRIBUTES" & + " PRED, SUCC, VAL, POS, IMAGE AND VALUE - 6"); + END IF; + + IF SUGAR'PRED (BROWN) /= GLUCOSE THEN + FAILED ("RESOLUTION INCORRECT FOR OPERANDS OF THE ATTRIBUTES" & + " PRED, SUCC, VAL, POS, IMAGE AND VALUE - 7"); + END IF; + + IF COLOR'SUCC (BROWN) /= RED THEN + FAILED ("RESOLUTION INCORRECT FOR OPERANDS OF THE ATTRIBUTES" & + " PRED, SUCC, VAL, POS, IMAGE AND VALUE - 8"); + END IF; + + IF SCHOOL'SUCC (BROWN) /= YALE THEN + FAILED ("RESOLUTION INCORRECT FOR OPERANDS OF THE ATTRIBUTES" & + " PRED, SUCC, VAL, POS, IMAGE AND VALUE - 9"); + END IF; + + IF COOK'SUCC (BROWN) /= BOIL THEN + FAILED ("RESOLUTION INCORRECT FOR OPERANDS OF THE ATTRIBUTES" & + " PRED, SUCC, VAL, POS, IMAGE AND VALUE - 10"); + END IF; + + IF COLOR'VAL (F2 (0)) /= BROWN THEN + FAILED ("RESOLUTION INCORRECT FOR OPERANDS OF THE ATTRIBUTES" & + " PRED, SUCC, VAL, POS, IMAGE AND VALUE - 11"); + END IF; + + IF SCHOOL'VAL (F2) /= BROWN THEN + FAILED ("RESOLUTION INCORRECT FOR OPERANDS OF THE ATTRIBUTES" & + " PRED, SUCC, VAL, POS, IMAGE AND VALUE - 12"); + END IF; + + IF COOK'VAL (F2 (2)) /= BROWN THEN + FAILED ("RESOLUTION INCORRECT FOR OPERANDS OF THE ATTRIBUTES" & + " PRED, SUCC, VAL, POS, IMAGE AND VALUE - 13"); + END IF; + + IF SUGAR'VAL (F2) /= CANE THEN + FAILED ("RESOLUTION INCORRECT FOR OPERANDS OF THE ATTRIBUTES" & + " PRED, SUCC, VAL, POS, IMAGE AND VALUE - 14"); + END IF; + + IF WHOLE'POS (1 + 1) /= 1 THEN + FAILED ("RESOLUTION INCORRECT FOR OPERANDS OF THE ATTRIBUTES" & + " PRED, SUCC, VAL, POS, IMAGE AND VALUE - 15"); + END IF; + + IF WHOLE'VAL (1 + 1) /= 2 THEN + FAILED ("RESOLUTION INCORRECT FOR OPERANDS OF THE ATTRIBUTES" & + " PRED, SUCC, VAL, POS, IMAGE AND VALUE - 16"); + END IF; + + IF WHOLE'SUCC (1 + 1) /= 2 THEN + FAILED ("RESOLUTION INCORRECT FOR OPERANDS OF THE ATTRIBUTES" & + " PRED, SUCC, VAL, POS, IMAGE AND VALUE - 17"); + END IF; + + IF WHOLE'PRED (1 + 1) /= 0 THEN + FAILED ("RESOLUTION INCORRECT FOR OPERANDS OF THE ATTRIBUTES" & + " PRED, SUCC, VAL, POS, IMAGE AND VALUE - 18"); + END IF; + + IF WHOLE'VALUE ("+1") + 1 /= 1 THEN + FAILED ("RESOLUTION INCORRECT FOR OPERANDS OF THE ATTRIBUTES" & + " PRED, SUCC, VAL, POS, IMAGE AND VALUE - 19"); + END IF; + + IF WHOLE'IMAGE (1 + 1) /= " 1" THEN + FAILED ("RESOLUTION INCORRECT FOR OPERANDS OF THE ATTRIBUTES" & + " PRED, SUCC, VAL, POS, IMAGE AND VALUE - 20"); + END IF; + + IF WHOLE'VALUE (F1) + 1 /= 10 THEN + FAILED ("RESOLUTION INCORRECT FOR OPERANDS OF THE ATTRIBUTES" & + " PRED, SUCC, VAL, POS, IMAGE AND VALUE - 21"); + END IF; + + IF WHOLE'VAL (1) + 1 /= 1 THEN + FAILED ("RESOLUTION INCORRECT FOR OPERANDS OF THE ATTRIBUTES" & + " PRED, SUCC, VAL, POS, IMAGE AND VALUE - 22"); + END IF; + + RESULT; +END C87B32A; diff --git a/gcc/testsuite/ada/acats/tests/c8/c87b33a.ada b/gcc/testsuite/ada/acats/tests/c8/c87b33a.ada new file mode 100644 index 000000000..5c398d463 --- /dev/null +++ b/gcc/testsuite/ada/acats/tests/c8/c87b33a.ada @@ -0,0 +1,117 @@ +-- C87B33A.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 OVERLOADING RESOLUTION USES THE RULE THAT: +-- +-- THE SHORT CIRCUIT CONTROL FORMS "AND THEN" AND "OR ELSE" ARE +-- DEFINED AS BINARY BOOLEAN OPERATORS WHICH RETURN A BOOLEAN VALUE +-- OF THE SAME TYPE AS THE OPERANDS. + +-- TRH 13 SEPT 82 + +WITH REPORT; USE REPORT; + +PROCEDURE C87B33A IS + + TYPE ON IS NEW BOOLEAN RANGE TRUE .. TRUE; + TYPE OFF IS NEW BOOLEAN RANGE FALSE .. FALSE; + TYPE YES IS NEW ON; + TYPE NO IS NEW OFF; + TYPE BIT IS NEW BOOLEAN; + TYPE FLAG IS (PASS, FAIL); + + TYPE BOOLEAN IS (FALSE, TRUE); -- STANDARD BOOLEAN HIDDEN. + + GENERIC + TYPE T IS PRIVATE; + ARG : IN T; + STAT : FLAG; + FUNCTION F1 RETURN T; + + FUNCTION F1 RETURN T IS + BEGIN + IF STAT = FAIL THEN + FAILED ("RESOLUTION INCORRECT FOR SHORT CIRCUIT " & + "CONTROL FORMS 'AND THEN' AND 'OR ELSE' "); + END IF; + RETURN ARG; + END F1; + + FUNCTION A IS NEW F1 (BOOLEAN, TRUE, FAIL); + FUNCTION A IS NEW F1 (NO, FALSE, PASS); + FUNCTION A IS NEW F1 (ON, TRUE, FAIL); + FUNCTION A IS NEW F1 (YES, TRUE, FAIL); + FUNCTION B IS NEW F1 (BOOLEAN, TRUE, FAIL); + FUNCTION B IS NEW F1 (NO, FALSE, FAIL); + FUNCTION B IS NEW F1 (OFF, FALSE, FAIL); + FUNCTION B IS NEW F1 (BIT, TRUE, FAIL); + FUNCTION C IS NEW F1 (BOOLEAN, FALSE, FAIL); + FUNCTION C IS NEW F1 (YES, TRUE, PASS); + FUNCTION C IS NEW F1 (ON, TRUE, FAIL); + FUNCTION C IS NEW F1 (NO, FALSE, FAIL); + FUNCTION D IS NEW F1 (BOOLEAN, FALSE, FAIL); + FUNCTION D IS NEW F1 (OFF, FALSE, FAIL); + FUNCTION D IS NEW F1 (YES, TRUE, FAIL); + FUNCTION D IS NEW F1 (BIT, TRUE, FAIL); + FUNCTION E IS NEW F1 (BOOLEAN, FALSE, FAIL); + FUNCTION E IS NEW F1 (BIT, TRUE, PASS); + FUNCTION E IS NEW F1 (YES, TRUE, FAIL); + FUNCTION E IS NEW F1 (NO, FALSE, FAIL); + FUNCTION F IS NEW F1 (BOOLEAN, FALSE, FAIL); + FUNCTION F IS NEW F1 (BIT, TRUE, PASS); + FUNCTION F IS NEW F1 (ON, TRUE, FAIL); + FUNCTION F IS NEW F1 (OFF, FALSE, FAIL); + FUNCTION G IS NEW F1 (BOOLEAN, TRUE, FAIL); + FUNCTION G IS NEW F1 (BIT, FALSE, PASS); + FUNCTION G IS NEW F1 (NO, FALSE, FAIL); + FUNCTION G IS NEW F1 (YES, TRUE, FAIL); + FUNCTION H IS NEW F1 (BOOLEAN, TRUE, FAIL); + FUNCTION H IS NEW F1 (BIT, FALSE, PASS); + FUNCTION H IS NEW F1 (OFF, FALSE, FAIL); + FUNCTION H IS NEW F1 (ON, TRUE, FAIL); + +BEGIN + TEST ("C87B33A","OVERLOADED OPERANDS FOR SHORT CIRCUIT CONTROL " & + "FORMS 'AND THEN' AND 'OR ELSE' "); + + IF (A AND THEN B) THEN + FAILED ("RESOLUTION INCORRECT FOR SHORT CIRCUIT FORMS - A&B"); + END IF; + + IF NOT (C OR ELSE D) THEN + FAILED ("RESOLUTION INCORRECT FOR SHORT CIRCUIT FORMS - C&D"); + END IF; + + IF NOT (E AND THEN F AND THEN E + AND THEN F AND THEN E AND THEN F) THEN + FAILED ("RESOLUTION INCORRECT FOR SHORT CIRCUIT FORMS - E&F"); + END IF; + + IF (G OR ELSE H OR ELSE G + OR ELSE H OR ELSE G OR ELSE H) THEN + FAILED ("RESOLUTION INCORRECT FOR SHORT CIRCUIT FORMS - G&H"); + END IF; + + RESULT; +END C87B33A; diff --git a/gcc/testsuite/ada/acats/tests/c8/c87b34a.ada b/gcc/testsuite/ada/acats/tests/c8/c87b34a.ada new file mode 100644 index 000000000..4291197af --- /dev/null +++ b/gcc/testsuite/ada/acats/tests/c8/c87b34a.ada @@ -0,0 +1,68 @@ +-- C87B34A.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 OVERLOADING RESOLUTION USES THE RULE THAT: +-- +-- THE MEMBERSHIP TESTS "IN" AND "NOT IN" RESULT IN THE PREDEFINED +-- TYPE BOOLEAN. + +-- TRH 4 AUG 82 + +WITH REPORT; USE REPORT; + +PROCEDURE C87B34A IS + + TYPE BIT IS NEW BOOLEAN; + TYPE FLAG IS NEW BOOLEAN; + + ERR : BOOLEAN := FALSE; + + PROCEDURE P1 (X : BIT) IS + BEGIN + ERR := TRUE; + END P1; + + PROCEDURE P1 (X : FLAG) IS + BEGIN + ERR := TRUE; + END P1; + + PROCEDURE P1 (X : BOOLEAN) IS + BEGIN + NULL; + END P1; + +BEGIN + TEST ("C87B34A","MEMBERSHIP TESTS 'IN' AND 'NOT IN' RETURN " & + "TYPE PREDEFINED BOOLEAN"); + + P1 (3 IN 1 .. 5); + P1 (3 NOT IN 1 .. 5); + + IF ERR THEN + FAILED ("MEMBERSHIP TESTS MUST RETURN PREDEFINED BOOLEAN TYPE"); + END IF; + + RESULT; +END C87B34A; diff --git a/gcc/testsuite/ada/acats/tests/c8/c87b34b.ada b/gcc/testsuite/ada/acats/tests/c8/c87b34b.ada new file mode 100644 index 000000000..17cdbcea0 --- /dev/null +++ b/gcc/testsuite/ada/acats/tests/c8/c87b34b.ada @@ -0,0 +1,71 @@ +-- C87B34B.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 OVERLOADING RESOLUTION USES THE RULE THAT: + +-- THE "IN" (OR MEMBERSHIP) OPERATOR OF THE FORM: X IN L .. R +-- REQUIRES THE OPERANDS X, L AND R TO BE OF THE SAME SCALAR TYPE. + +-- TRH 19 JULY 82 +-- PWN 01/31/95 REMOVED INCONSISTENCIES WITH ADA 9X. + +WITH REPORT; USE REPORT; + +PROCEDURE C87B34B IS + + TYPE FLAG IS (PASS, FAIL); + + GENERIC + TYPE T IS PRIVATE; + ARG : IN T; + STAT : IN FLAG; + FUNCTION F1 RETURN T; + + FUNCTION F1 RETURN T IS + BEGIN + IF STAT = FAIL THEN + FAILED ("RESOLUTION INCORRECT FOR 'IN' MEMBERSHIP TEST"); + END IF; + RETURN ARG; + END F1; + + FUNCTION X IS NEW F1 (FLOAT, 2.0, PASS); + FUNCTION L IS NEW F1 (FLOAT, -1.0, PASS); + FUNCTION R IS NEW F1 (FLOAT, 1.0, PASS); + FUNCTION X IS NEW F1 (INTEGER, 5, FAIL); + FUNCTION L IS NEW F1 (INTEGER, 1, FAIL); + FUNCTION L IS NEW F1 (CHARACTER, 'A', FAIL); + FUNCTION R IS NEW F1 (CHARACTER, 'E', FAIL); + FUNCTION X IS NEW F1 (BOOLEAN, TRUE, FAIL); + FUNCTION R IS NEW F1 (BOOLEAN, TRUE, FAIL); + +BEGIN + TEST ("C87B34B","OVERLOADED MEMBERSHIP OPERANDS"); + + IF X IN L .. R THEN + FAILED ("RESOLUTION INCORRECT FOR MEMBERSHIP OPERATOR"); + END IF; + + RESULT; +END C87B34B; diff --git a/gcc/testsuite/ada/acats/tests/c8/c87b34c.ada b/gcc/testsuite/ada/acats/tests/c8/c87b34c.ada new file mode 100644 index 000000000..7b8dc5930 --- /dev/null +++ b/gcc/testsuite/ada/acats/tests/c8/c87b34c.ada @@ -0,0 +1,75 @@ +-- C87B34C.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 OVERLOADING RESOLUTION USES THE RULE THAT: + +-- FOR A MEMBERSHIP RELATION WITH A TYPEMARK, THE TYPE OF THE +-- SIMPLE EXPRESSION MUST BE THE BASE TYPE OF THE TYPEMARK. + +-- TRH 15 SEPT 82 +-- PWN 01/31/95 REMOVED INCONSISTENCIES WITH ADA 9X. + +WITH REPORT; USE REPORT; + +PROCEDURE C87B34C IS + + TYPE VOWEL IS (A, E, I, O, U, VOCALIC_Y); + TYPE ALPHA IS (A, 'A'); + TYPE GRADE IS (A, B, C, D, F); + SUBTYPE BAD_GRADE IS GRADE RANGE D .. F; + SUBTYPE PASSING IS GRADE RANGE A .. C; + + GENERIC + TYPE T IS PRIVATE; + ARG : IN T; + FUNCTION F1 RETURN T; + + FUNCTION F1 RETURN T IS + BEGIN + FAILED ("RESOLUTION INCORRECT - EXPRESSION IN MEMBER" & + "SHIP TEST WITH TYPEMARK MUST MATCH TYPEMARK"); + RETURN ARG; + END F1; + + FUNCTION F IS NEW F1 (CHARACTER, 'A'); + FUNCTION F IS NEW F1 (DURATION, 1.0); + FUNCTION F IS NEW F1 (INTEGER, -10); + FUNCTION F IS NEW F1 (BOOLEAN, TRUE); + FUNCTION F IS NEW F1 (FLOAT, 1.0); + FUNCTION F IS NEW F1 (VOWEL, A); + FUNCTION F IS NEW F1 (ALPHA, A); + +BEGIN + TEST ("C87B34C","OVERLOADED EXPRESSION IN MEMBERSHIP TEST " & + "WITH A TYPEMARK"); + + IF (F NOT IN GRADE) OR (F NOT IN BAD_GRADE) + OR (F IN PASSING) THEN + FAILED ("RESOLUTION INCORRECT FOR MEMBERSHIP TEST " & + "WITH TYPEMARK"); + END IF; + + RESULT; + +END C87B34C; diff --git a/gcc/testsuite/ada/acats/tests/c8/c87b35c.ada b/gcc/testsuite/ada/acats/tests/c8/c87b35c.ada new file mode 100644 index 000000000..89a839f6d --- /dev/null +++ b/gcc/testsuite/ada/acats/tests/c8/c87b35c.ada @@ -0,0 +1,82 @@ +-- C87B35C.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 OVERLOADING RESOLUTION USES THE RULE THAT: +-- +-- THE EXPONENT OPERAND OF A FLOATING POINT EXPONENTIATION MUST BE +-- OF THE TYPE PREDEFINED INTEGER. + +-- TRH 4 AUG 82 + +WITH REPORT; USE REPORT; + +PROCEDURE C87B35C IS + + TYPE FIXED IS DELTA 0.01 RANGE 0.0 .. 4.0; + ERR : BOOLEAN := FALSE; + + FUNCTION F1 (X : INTEGER) RETURN INTEGER IS + BEGIN + RETURN X; + END F1; + + FUNCTION F1 (X : INTEGER) RETURN FLOAT IS + BEGIN + ERR := TRUE; + RETURN 1.0; + END F1; + + FUNCTION F1 (X : INTEGER) RETURN FIXED IS + BEGIN + ERR := TRUE; + RETURN 1.0; + END F1; + +BEGIN + TEST ("C87B35C","EXPONENT OPERAND FOR FLOATING POINT " & + "EXPONENTIATION MUST BE OF TYPE PREDEFINED INTEGER"); + + DECLARE + FUNCTION "+" (X, Y : INTEGER) RETURN INTEGER + RENAMES STANDARD."*"; + + BEGIN + IF ( FLOAT'(2.0) ** F1(3) /= 8.0 OR + FLOAT'(2.0) ** (3 + 1) /= 8.0 ) THEN + FAILED ("EXPONENT OF FLOATING POINT EXPONENTIATION " + & "MUST BE PREDEFINED INTEGER (A)"); + END IF; + IF ( 2.0 ** F1(3) /= FLOAT'(8.0) OR + 2.0 ** (3 + 1) /= FLOAT'(8.0) ) THEN + FAILED ("EXPONENT OF FLOATING POINT EXPONENTIATION" + & "MUST BE PREDEFINED INTEGER (B)"); + END IF; + IF ERR THEN + FAILED ("EXPONENT OF FLOATING POINT EXPONENTIATION" + & "MUST BE PREDEFINED INTEGER (C)"); + END IF; + END; + + RESULT; +END C87B35C; diff --git a/gcc/testsuite/ada/acats/tests/c8/c87b38a.ada b/gcc/testsuite/ada/acats/tests/c8/c87b38a.ada new file mode 100644 index 000000000..46ba65185 --- /dev/null +++ b/gcc/testsuite/ada/acats/tests/c8/c87b38a.ada @@ -0,0 +1,76 @@ +-- C87B38A.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 OVERLOADING RESOLUTION USES THE RULE THAT: + +-- IN A QUALIFIED EXPRESSION, THE OPERAND MUST HAVE THE SAME TYPE +-- AS THE BASE TYPE OF THE TYPEMARK. + +-- TRH 13 SEPT 82 + +WITH REPORT; USE REPORT; + +PROCEDURE C87B38A IS + + SUBTYPE BOOL IS BOOLEAN; + TYPE YES IS NEW BOOLEAN RANGE TRUE .. TRUE; + TYPE NO IS NEW BOOLEAN RANGE FALSE .. FALSE; + TYPE BIT IS NEW BOOLEAN; + TYPE LIT IS (FALSE, TRUE); + TYPE FLAG IS (PASS, FAIL); + + GENERIC + TYPE T IS PRIVATE; + ARG : IN T; + STAT : FLAG; + FUNCTION F1 RETURN T; + + FUNCTION F1 RETURN T IS + BEGIN + IF STAT = FAIL THEN + FAILED ("RESOLUTION INCORRECT FOR OVERLOADED " & + " OPERANDS OF QUALIFIED EXPRESSIONS"); + END IF; + RETURN ARG; + END F1; + + FUNCTION F IS NEW F1 (LIT, FALSE, FAIL); + FUNCTION F IS NEW F1 (BIT, TRUE, FAIL); + FUNCTION F IS NEW F1 (BOOLEAN, TRUE, PASS); + FUNCTION F IS NEW F1 (YES, TRUE, FAIL); + FUNCTION F IS NEW F1 (NO, FALSE, FAIL); + +BEGIN + TEST ("C87B38A","OVERLOADED OPERANDS IN QUALIFIED EXPRESSIONS "); + + DECLARE + B : BOOL; + + BEGIN + B := BOOL' (F); + B := BOOL' ((NOT F) OR ELSE (F AND THEN F)); + END; + + RESULT; +END C87B38A; diff --git a/gcc/testsuite/ada/acats/tests/c8/c87b39a.ada b/gcc/testsuite/ada/acats/tests/c8/c87b39a.ada new file mode 100644 index 000000000..75c855962 --- /dev/null +++ b/gcc/testsuite/ada/acats/tests/c8/c87b39a.ada @@ -0,0 +1,106 @@ +-- C87B39A.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) AN OVERLOADED CALL CAN BE RESOLVED BECAUSE AN ALLOCATOR RETURNS +-- AN ACCESS TYPE WHOSE DESIGNATED TYPE IS THE TYPE REFERRED TO IN +-- THE ALLOCATOR. +-- +-- B) IF THE NAME OF THE DESIGNATED TYPE IN AN ALLOCATOR DOES NOT +-- UNIQUELY DETERMINE THE ACCESS TYPE OF AN ALLOCATOR, THE CONTEXT +-- MUST DETERMINE THE TYPE. + +-- JBG 1/30/84 + +WITH REPORT; USE REPORT; +PROCEDURE C87B39A IS + + TYPE S IS (M, F); + TYPE R (D : S) IS + RECORD NULL; END RECORD; + SUBTYPE M1 IS R(M); + SUBTYPE M2 IS R(M); + + TYPE ACC_M1 IS ACCESS M1; + TYPE ACC_M2 IS ACCESS M2; + TYPE ACC_BOOL IS ACCESS BOOLEAN; + TYPE ACC_ACC_M1 IS ACCESS ACC_M1; + + TYPE WHICH IS (IS_M1, IS_M2, IS_BOOL); + + PROCEDURE P (X : ACC_M1; RESOLUTION : WHICH) IS + BEGIN + IF RESOLUTION /= IS_M1 THEN + FAILED ("INCORRECT RESOLUTION -- ACC_M1"); + END IF; + END P; -- ACC_M1 + + PROCEDURE P (X : ACC_M2; RESOLUTION : WHICH) IS + BEGIN + IF RESOLUTION /= IS_M2 THEN + FAILED ("INCORRECT RESOLUTION -- ACC_M2"); + END IF; + END P; -- ACC_M2 + + PROCEDURE P (X : ACC_BOOL; RESOLUTION : WHICH) IS + BEGIN + IF RESOLUTION /= IS_BOOL THEN + FAILED ("INCORRECT RESOLUTION -- ACC_BOOL"); + END IF; + END P; -- ACC_BOOL + + PROCEDURE P (X : ACC_ACC_M1; RESOLUTION : WHICH) IS + BEGIN + FAILED ("INCORRECT RESOLUTION -- ACC_ACC_M1"); + END P; -- ACC_ACC_M1 + + PROCEDURE Q (X : ACC_M1) IS + BEGIN + NULL; + END Q; -- ACC_M1 + + PROCEDURE Q (X : ACC_BOOL) IS + BEGIN + FAILED ("INCORRECT RESOLUTION -- ACC_BOOL: Q"); + END Q; -- ACC_BOOL + +BEGIN + + TEST ("C87B39A", "OVERLOADING RESOLUTION FOR ALLOCATORS"); + + P (ACC_M1'(NEW R(M)), IS_M1); -- B + + P (ACC_M2'(NEW M1), IS_M2); -- B + + P (NEW BOOLEAN'(TRUE), IS_BOOL); -- A + + Q (NEW M2); -- A + Q (NEW M1); -- A + Q (NEW R(M)); -- A + Q (NEW R'(D => M)); -- A + + RESULT; + +END C87B39A; diff --git a/gcc/testsuite/ada/acats/tests/c8/c87b40a.ada b/gcc/testsuite/ada/acats/tests/c8/c87b40a.ada new file mode 100644 index 000000000..5fd04a16b --- /dev/null +++ b/gcc/testsuite/ada/acats/tests/c8/c87b40a.ada @@ -0,0 +1,106 @@ +-- C87B40A.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 OVERLOADING RESOLUTION USES THE FOLLOWING RULES: +-- +-- THE SAME OPERATIONS ARE PREDEFINED FOR THE TYPE UNIVERSAL_INTEGER +-- AS FOR ANY INTEGER TYPE. THE SAME OPERATIONS ARE PREDEFINED FOR THE +-- TYPE UNIVERSAL_REAL AS FOR ANY FLOATING POINT TYPE. IN ADDITION +-- THESE OPERATIONS INCLUDE THE FOLLOWING MULTIPLICATION AND DIVISION +-- OPERATORS: +-- +-- "*" (UNIVERSAL_REAL, UNIVERSAL_INTEGER) RETURN UNIVERSAL_REAL +-- "*" (UNIVERSAL_INTEGER, UNIVERSAL_REAL) RETURN UNIVERSAL_REAL +-- "*" (UNIVERSAL_REAL, UNIVERSAL_REAL) RETURN UNIVERSAL_REAL +-- "*" (UNIVERSAL_INTEGER, UNIVERSAL_INTEGER) RETURN UNIVERSAL_INTEGER +-- "/" (UNIVERSAL_REAL, UNIVERSAL_INTEGER) RETURN UNIVERSAL_REAL +-- "**" (UNIVERSAL_INTEGER, INTEGER) RETURN UNIVERSAL_INTEGER +-- "**" (UNIVERSAL_REAL, INTEGER) RETURN UNIVERSAL_REAL +-- "MOD" (UNIVERSAL_INTEGER, UNIVERSAL_INTEGER) RETURN UNIVERSAL_INTEGER +-- "DIV" (UNIVERSAL_INTEGER, UNIVERSAL_INTEGER) RETURN UNIVERSAL_INTEGER +-- "ABS" (UNIVERSAL_INTEGER) RETURN UNIVERSAL INTEGER +-- "ABS" (UNIVERSAL_REAL) RETURN UNIVERSAL_REAL + +-- TRH 15 SEPT 82 + +WITH REPORT; USE REPORT; + +PROCEDURE C87B40A IS + + ERR : BOOLEAN := FALSE; + B : ARRAY (1 .. 12) OF BOOLEAN := (1 .. 12 => TRUE); + + FUNCTION "-" (X : INTEGER) RETURN INTEGER + RENAMES STANDARD."+"; + + FUNCTION "+" (X : INTEGER) RETURN INTEGER IS + BEGIN + ERR := TRUE; + RETURN X; + END "+"; + + FUNCTION "+" (X : FLOAT) RETURN FLOAT IS + BEGIN + ERR := TRUE; + RETURN X; + END "+"; + +BEGIN + TEST ("C87B40A","OVERLOADING RESOLUTION OF UNIVERSAL " & + "EXPRESSIONS"); + + B(1) := 1.0 * (+1) IN 0.0 .. 0.0; -- 1.0 * 1 + B(2) := (+1) * 1.0 IN 0.0 .. 0.0; -- 1 * 1.0 + B(3) := 1.0 / (+1) IN 0.0 .. 0.0; -- 1.0 / 1 + B(4) := (+1) + (+1) <= (+1) - (+1); -- 1+1< 1 - 1 + B(5) := (+1) * (+1) > (+1) / (+1); -- 1*1 > 1/1 + B(6) := (+1) MOD (+1) /= (+1) REM (+1); -- 1 MOD 1 /= 1 REM 1 + + BEGIN + B(7) := (+2) ** (-2) < "-" (-1); -- 2**2 < 1 + EXCEPTION + WHEN CONSTRAINT_ERROR => + FAILED("INCORRECT RESOLUTION FOR INTEGER EXPONENT - 7"); + END; + + B(8) := (+1) REM (+1) > "ABS" (+1); -- 1 REM 1 > ABS 1 + B(9) := (+1.0) + (+1.0) <= (+1.0) - (+1.0); -- 2.0 <= 0.0 + B(10) := (+1.0) * (+1.0) > (+1.0) / (+1.0); -- 1.0 > 1.0 + B(11) := (+2.0) ** (-1) < "-" (-1.0); -- 2.0 < 1.0 + B(12) := (+2.0) ** (-1) <= "ABS" (+1.0); -- 2.0 <= 1.0 + + FOR I IN B'RANGE + LOOP + IF B(I) /= FALSE THEN + FAILED("RESOLUTION OR OPERATIONS INCORRECT FOR " + & "UNIVERSAL EXPRESSIONS - " & INTEGER'IMAGE(I) ); + END IF; + END LOOP; + + IF ERR THEN + FAILED ("RESOLUTION INCORRECT FOR UNIVERSAL EXPRESSIONS"); + END IF; + + RESULT; +END C87B40A; diff --git a/gcc/testsuite/ada/acats/tests/c8/c87b41a.ada b/gcc/testsuite/ada/acats/tests/c8/c87b41a.ada new file mode 100644 index 000000000..ae60c8d51 --- /dev/null +++ b/gcc/testsuite/ada/acats/tests/c8/c87b41a.ada @@ -0,0 +1,112 @@ +-- C87B41A.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 OVERLOADING RESOLUTION USES THE RULE THAT: +-- +-- THE NAMED VARIABLE AND THE RIGHT HAND SIDE EXPRESSION +-- IN AN ASSIGNMENT STATEMENT MUST BE OF THE SAME TYPE. THIS TYPE +-- MUST NOT BE A LIMITED TYPE. + +-- TRH 15 SEPT 82 +-- PWN 01/31/95 REMOVED INCONSISTENCIES WITH ADA 9X. + +WITH REPORT; USE REPORT; + +PROCEDURE C87B41A IS + + TYPE NOTE IS (A, B, C, D, E, F, G); + TYPE POSITIVE IS NEW INTEGER RANGE 1 .. INTEGER'LAST; + TYPE ACC_CHAR IS ACCESS CHARACTER; + TYPE ACC_DUR IS ACCESS DURATION; + TYPE ACC_POS IS ACCESS POSITIVE; + TYPE ACC_INT IS ACCESS INTEGER; + TYPE ACC_BOOL IS ACCESS BOOLEAN; + TYPE ACC_STR IS ACCESS STRING; + TYPE ACC_FLT IS ACCESS FLOAT; + TYPE ACC_NOTE IS ACCESS NOTE; + + TYPE NEW_CHAR IS NEW CHARACTER; + TYPE NEW_DUR IS NEW DURATION; + TYPE NEW_POS IS NEW POSITIVE; + TYPE NEW_INT IS NEW INTEGER; + TYPE NEW_BOOL IS NEW BOOLEAN; + TYPE NEW_FLT IS NEW FLOAT; + TYPE NEW_NOTE IS NEW NOTE RANGE A .. F; + TASK TYPE T; + + TASK BODY T IS + BEGIN + NULL; + END T; + + FUNCTION G RETURN T IS + T1 : T; + BEGIN + FAILED ("LIMITED TYPES MAY NOT OCCUR IN ASSIGNMENT " & + "STATEMENTS"); + RETURN T1; + END G; + + GENERIC + TYPE T IS PRIVATE; + ARG : IN T; + FUNCTION F1 RETURN T; + + FUNCTION F1 RETURN T IS + BEGIN + FAILED ("RESOLUTION INCORRECT - RIGHT HAND SIDE OF " & + "ASSIGNMENT STATEMENT MUST MATCH TYPE OF VARIABLE"); + RETURN ARG; + END F1; + + FUNCTION F IS NEW F1 (ACC_CHAR, NEW CHARACTER); + FUNCTION F IS NEW F1 (ACC_DUR, NEW DURATION); + FUNCTION F IS NEW F1 (ACC_POS, NEW POSITIVE); + FUNCTION F IS NEW F1 (ACC_INT, NEW INTEGER); + FUNCTION F IS NEW F1 (ACC_BOOL, NEW BOOLEAN); + FUNCTION F IS NEW F1 (ACC_STR, NEW STRING(1..2) ); + FUNCTION F IS NEW F1 (ACC_FLT, NEW FLOAT); + + FUNCTION F RETURN ACC_NOTE IS + BEGIN + RETURN (NEW NOTE); + END F; + + FUNCTION G IS NEW F1 (NEW_CHAR, 'G'); + FUNCTION G IS NEW F1 (NEW_DUR, 1.0); + FUNCTION G IS NEW F1 (NEW_POS, +10); + FUNCTION G IS NEW F1 (NEW_INT, -10); + FUNCTION G IS NEW F1 (NEW_BOOL, TRUE); + FUNCTION G IS NEW F1 (NEW_FLT, 1.0); + FUNCTION G IS NEW F1 (NEW_NOTE, F); + +BEGIN + TEST ("C87B41A","OVERLOADED CONSTRUCTS ON BOTH SIDES OF THE " & + "ASSIGNMENT STATEMENT"); + + F.ALL := G; + + RESULT; + +END C87B41A; diff --git a/gcc/testsuite/ada/acats/tests/c8/c87b42a.ada b/gcc/testsuite/ada/acats/tests/c8/c87b42a.ada new file mode 100644 index 000000000..9365d5852 --- /dev/null +++ b/gcc/testsuite/ada/acats/tests/c8/c87b42a.ada @@ -0,0 +1,77 @@ +-- C87B42A.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 OVERLOADING RESOLUTION USES THE RULE THAT: +-- +-- A CONDITIONAL EXPRESSION MUST BE OF A BOOLEAN TYPE. + +-- TRH 27 JULY 82 +-- PWN 01/31/95 REMOVED INCONSISTENCIES WITH ADA 9X. + +WITH REPORT; USE REPORT; + +PROCEDURE C87B42A IS + + TYPE BIT IS NEW BOOLEAN; + TYPE BOOLEAN IS (FALSE, TRUE); + TYPE LIT IS (FALSE, TRUE); + TYPE FLAG IS (PASS, FAIL); + + GENERIC + TYPE T IS PRIVATE; + ARG : IN T; + STAT : FLAG; + FUNCTION F1 RETURN T; + + FUNCTION F1 RETURN T IS + BEGIN + IF STAT = FAIL THEN + FAILED ("CONDITIONAL EXPRESSION MUST BE OF A BOOLEAN" & + " TYPE"); + END IF; + RETURN ARG; + END F1; + + FUNCTION F IS NEW F1 (BOOLEAN, FALSE, FAIL); + FUNCTION F IS NEW F1 (BIT, FALSE, PASS); + FUNCTION F IS NEW F1 (LIT, FALSE, FAIL); + FUNCTION F IS NEW F1 (INTEGER, -11, FAIL); + FUNCTION F IS NEW F1 (FLOAT, +0.0, FAIL); + +BEGIN + TEST ("C87B42A","OVERLOADED CONDITIONAL EXPRESSIONS"); + + WHILE (F OR NOT F) + LOOP + IF (F OR ELSE NOT F) THEN + NULL; + END IF; + EXIT WHEN (F AND NOT F); + EXIT WHEN (F OR NOT F); + EXIT WHEN (F); + EXIT WHEN (NOT F); + END LOOP; + + RESULT; +END C87B42A; diff --git a/gcc/testsuite/ada/acats/tests/c8/c87b43a.ada b/gcc/testsuite/ada/acats/tests/c8/c87b43a.ada new file mode 100644 index 000000000..9bb11fd6e --- /dev/null +++ b/gcc/testsuite/ada/acats/tests/c8/c87b43a.ada @@ -0,0 +1,60 @@ +-- C87B43A.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 OVERLOADING RESOLUTION USES THE RULE THAT: +-- +-- IN A CASE STATEMENT, THE TYPE OF EACH CHOICE MUST MATCH THE TYPE +-- OF THE EXPRESSION. + +-- TRH 3 AUG 82 +-- DSJ 10 JUN 83 + +WITH REPORT; USE REPORT; + +PROCEDURE C87B43A IS + + TYPE WHOLE IS NEW INTEGER RANGE 0 .. INTEGER'LAST; + + FUNCTION "+" (X, Y : INTEGER) RETURN INTEGER + RENAMES "*"; + + ERR : BOOLEAN := FALSE; + X : WHOLE := 6; + +BEGIN + TEST ("C87B43A","TYPE OF CASE CHOICE MUST MATCH TYPE OF " & + "EXPRESSION"); + + CASE X IS + WHEN (2 + 3) => ERR := TRUE; + WHEN (3 + 3) => NULL; + WHEN OTHERS => ERR := TRUE; + END CASE; + + IF ERR THEN + FAILED ("CASE STATEMENT CHOICE MUST MATCH TYPE OF EXPRESSION"); + END IF; + + RESULT; +END C87B43A; diff --git a/gcc/testsuite/ada/acats/tests/c8/c87b44a.ada b/gcc/testsuite/ada/acats/tests/c8/c87b44a.ada new file mode 100644 index 000000000..66acd0340 --- /dev/null +++ b/gcc/testsuite/ada/acats/tests/c8/c87b44a.ada @@ -0,0 +1,112 @@ +-- C87B44A.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 OVERLOADING RESOLUTION USES THE RULE THAT: +-- +-- THE TYPE OF THE EXPRESSION IN A RETURN STATEMENT MUST MATCH THE +-- EXPLICIT TYPEMARK IN THE RETURN CLAUSE OF THE FUNCTION'S +-- SPECIFICATION. +-- +-- THE FOUR KINDS OF EXPRESSIONS TESTED HERE ARE: +-- +-- (A): A CALL TO AN OVERLOADED FUNCTION. +-- (B): AN OVERLOADED OPERATOR SYMBOL. +-- (C): AN OVERLOADED (INFIX) OPERATOR. +-- (D): AN OVERLOADED ENUMERATION LITERAL. + +-- TRH 25 JUNE 82 + +WITH REPORT; USE REPORT; + +PROCEDURE C87B44A IS + + TYPE WHOLE IS NEW INTEGER RANGE 0..INTEGER'LAST; + TYPE CITRUS IS (LEMON, LIME, ORANGE); + TYPE HUE IS (RED, ORANGE, YELLOW); + + FUNCTION F1 (X, Y : INTEGER) RETURN INTEGER IS + BEGIN + RETURN -1; + END F1; + + FUNCTION "*" (X, Y : WHOLE) RETURN WHOLE IS + BEGIN + RETURN 0; + END "*"; + + FUNCTION "*" (X, Y : INTEGER) RETURN HUE IS + BEGIN + RETURN ORANGE; + END "*"; + + FUNCTION F1 (X, Y : INTEGER) RETURN CITRUS IS + BEGIN + RETURN ORANGE; + END F1; + +BEGIN + TEST ("C87B44A","OVERLOADED EXPRESSIONS IN RETURN STATEMENTS"); + DECLARE + + FUNCTION F2 (X, Y : INTEGER) RETURN INTEGER IS + BEGIN + RETURN F1 (X, Y); + END F2; + + FUNCTION F2 (X, Y : WHOLE) RETURN WHOLE IS + BEGIN + RETURN "*" (X, Y); + END F2; + + FUNCTION F2 (X, Y : INTEGER) RETURN HUE IS + BEGIN + RETURN (X * Y); + END F2; + + FUNCTION F2 (X, Y : INTEGER) RETURN CITRUS IS + BEGIN + RETURN ORANGE; + END F2; + + + BEGIN + IF INTEGER'(F2 (0, 0)) /= -1 THEN + FAILED ("(A): RESOLUTION INCORRECT - FUNCTION CALL"); + END IF; + + IF WHOLE'(F2 (0, 0)) /= 0 THEN + FAILED ("(B): RESOLUTION INCORRECT - OPERATOR SYMBOL"); + END IF; + + IF HUE'POS (F2 (0, 0)) /= 1 THEN + FAILED ("(C): RESOLUTION INCORRECT - INFIX OPERATOR"); + END IF; + + IF CITRUS'POS (F2 (0, 0)) /= 2 THEN + FAILED ("(D): RESOLUTION INCORRECT - ENUMERATION LITERAL"); + END IF; + END; + + RESULT; +END C87B44A; diff --git a/gcc/testsuite/ada/acats/tests/c8/c87b45a.ada b/gcc/testsuite/ada/acats/tests/c8/c87b45a.ada new file mode 100644 index 000000000..497de84f7 --- /dev/null +++ b/gcc/testsuite/ada/acats/tests/c8/c87b45a.ada @@ -0,0 +1,126 @@ +-- C87B45A.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 OVERLOADING RESOLUTION USES THE RULE THAT: +-- +-- FOR A DEFAULT SUBPROGRAM PARAMETER, THE TYPE OF THE INITIALIZATION +-- EXPRESSION MUST MATCH THE PARAMETERS'S EXPLICIT TYPEMARK. +-- +-- THE FOUR KINDS OF EXPRESSIONS TESTED HERE ARE: +-- +-- (A): A CALL TO AN OVERLOADED FUNCTION. +-- (B): AN OVERLOADED OPERATOR SYMBOL. +-- (C): AN OVERLOADED (INFIX) OPERATOR. +-- (D): AN OVERLOADED ENUMERATION LITERAL. + +-- TRH 24 JUNE 82 + +WITH REPORT; USE REPORT; + +PROCEDURE C87B45A IS + + TYPE WHOLE IS NEW INTEGER RANGE 0..INTEGER'LAST; + TYPE CITRUS IS (LEMON, LIME, ORANGE); + TYPE HUE IS (RED, ORANGE, YELLOW); + + FUNCTION F1 (X, Y : INTEGER) RETURN INTEGER IS + BEGIN + RETURN -1; + END F1; + + FUNCTION F1 (X, Y : WHOLE) RETURN WHOLE IS + BEGIN + RETURN 0; + END F1; + + FUNCTION F1 (X, Y : INTEGER) RETURN HUE IS + BEGIN + RETURN ORANGE; + END F1; + + FUNCTION F1 (X, Y : INTEGER) RETURN CITRUS IS + BEGIN + RETURN ORANGE; + END F1; + +BEGIN + TEST ("C87B45A","OVERLOADED INITIALIZATION EXPRESSIONS" & + " IN DEFAULT SUBPROGRAM PARAMETERS"); + DECLARE + + FUNCTION "/" (X, Y : INTEGER) RETURN INTEGER + RENAMES F1; + + FUNCTION "/" (X, Y : WHOLE) RETURN WHOLE + RENAMES F1; + + FUNCTION "/" (X, Y : INTEGER) RETURN HUE + RENAMES F1; + + FUNCTION "/" (X, Y : INTEGER) RETURN CITRUS + RENAMES F1; + + PROCEDURE P1 (I1 : INTEGER := F1 (0, 0); + W1 : WHOLE := F1 (0, 0); + C1 : CITRUS := F1 (0, 0); + H1 : HUE := F1 (0, 0); + I2 : INTEGER := "/" (0, 0); + W2 : WHOLE := "/" (0, 0); + C2 : CITRUS := "/" (0, 0); + H2 : HUE := "/" (0, 0); + I3 : INTEGER := (0 / 0); + W3 : WHOLE := (0 / 0); + C3 : CITRUS := (0 / 0); + H3 : HUE := (0 / 0); + C4 : CITRUS := ORANGE; + H4 : HUE := ORANGE) IS + BEGIN + IF I1 /= -1 OR W1 /= 0 OR + CITRUS'POS (C1) /= 2 OR HUE'POS (H1) /= 1 THEN + FAILED ("(A): RESOLUTION INCORRECT - FUNCTION CALL"); + END IF; + + IF I2 /= -1 OR W2 /= 0 OR + CITRUS'POS (C2) /= 2 OR HUE'POS (H2) /= 1 THEN + FAILED ("(B): RESOLUTION INCORRECT " & + "- OPERATOR SYMBOL"); + END IF; + + IF I3 /= -1 OR W3 /= 0 OR + CITRUS'POS (C3) /= 2 OR HUE'POS (H3) /= 1 THEN + FAILED ("(C): RESOLUTION INCORRECT - INFIX OPERATOR"); + END IF; + + IF CITRUS'POS (C4) /= 2 OR HUE'POS (H4) /= 1 THEN + FAILED ("(D): RESOLUTION INCORRECT - ENUMERATION " & + "LITERAL"); + END IF; + END P1; + + BEGIN + P1; + END; + + RESULT; +END C87B45A; diff --git a/gcc/testsuite/ada/acats/tests/c8/c87b45c.ada b/gcc/testsuite/ada/acats/tests/c8/c87b45c.ada new file mode 100644 index 000000000..d70687a7e --- /dev/null +++ b/gcc/testsuite/ada/acats/tests/c8/c87b45c.ada @@ -0,0 +1,148 @@ +-- C87B45C.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 OVERLOADING RESOLUTION USES THE RULE THAT: +-- +-- FOR A DEFAULT ENTRY PARAMETER, THE TYPE OF THE INITIALIZATION +-- EXPRESSION MUST MATCH THE PARAMETERS'S EXPLICIT TYPEMARK. +-- +-- THE FOUR KINDS OF EXPRESSIONS TESTED HERE ARE: +-- +-- (A): A CALL TO AN OVERLOADED FUNCTION. +-- (B): AN OVERLOADED OPERATOR SYMBOL. +-- (C): AN OVERLOADED (INFIX) OPERATOR. +-- (D): AN OVERLOADED ENUMERATION LITERAL. + +-- TRH 7 JULY 82 + +WITH REPORT; USE REPORT; + +PROCEDURE C87B45C IS + + TYPE WHOLE IS NEW INTEGER RANGE 0..INTEGER'LAST; + TYPE CITRUS IS (LEMON, LIME, ORANGE); + TYPE HUE IS (RED, ORANGE, YELLOW); + + FUNCTION F1 (X, Y : INTEGER) RETURN INTEGER IS + BEGIN + RETURN -1; + END F1; + + FUNCTION F1 (X, Y : WHOLE) RETURN WHOLE IS + BEGIN + RETURN 0; + END F1; + + FUNCTION F1 (X, Y : INTEGER) RETURN HUE IS + BEGIN + RETURN ORANGE; + END F1; + + FUNCTION F1 (X, Y : INTEGER) RETURN CITRUS IS + BEGIN + RETURN ORANGE; + END F1; + +BEGIN + TEST ("C87B45C","OVERLOADED INITIALIZATION EXPRESSIONS" & + " IN DEFAULT ENTRY PARAMETERS"); + DECLARE + + FUNCTION "*" (X, Y : INTEGER) RETURN INTEGER + RENAMES F1; + + FUNCTION "*" (X, Y : WHOLE) RETURN WHOLE + RENAMES F1; + + FUNCTION "*" (X, Y : INTEGER) RETURN HUE + RENAMES F1; + + FUNCTION "*" (X, Y : INTEGER) RETURN CITRUS + RENAMES F1; + + TASK T1 IS + ENTRY E1 (I1 : INTEGER := F1 (0, 0); + W1 : WHOLE := F1 (0, 0); + C1 : CITRUS := F1 (0, 0); + H1 : HUE := F1 (0, 0); + I2 : INTEGER := "*" (0, 0); + W2 : WHOLE := "*" (0, 0); + C2 : CITRUS := "*" (0, 0); + H2 : HUE := "*" (0, 0); + I3 : INTEGER := (0 * 0); + W3 : WHOLE := (0 * 0); + C3 : CITRUS := (0 * 0); + H3 : HUE := (0 * 0); + C4 : CITRUS := ORANGE; + H4 : HUE := ORANGE); + END T1; + + TASK BODY T1 IS + BEGIN + ACCEPT E1 (I1 : INTEGER := F1 (0, 0); + W1 : WHOLE := F1 (0, 0); + C1 : CITRUS := F1 (0, 0); + H1 : HUE := F1 (0, 0); + I2 : INTEGER := "*" (0, 0); + W2 : WHOLE := "*" (0, 0); + C2 : CITRUS := "*" (0, 0); + H2 : HUE := "*" (0, 0); + I3 : INTEGER := (0 * 0); + W3 : WHOLE := (0 * 0); + C3 : CITRUS := (0 * 0); + H3 : HUE := (0 * 0); + C4 : CITRUS := ORANGE; + H4 : HUE := ORANGE) DO + + IF I1 /= -1 OR W1 /= 0 OR + CITRUS'POS (C1) /= 2 OR HUE'POS (H1) /= 1 THEN + FAILED ("(A): RESOLUTION INCORRECT - FUNCTION"); + END IF; + + IF I2 /= -1 OR W2 /= 0 OR + CITRUS'POS (C2) /= 2 OR HUE'POS (H2) /= 1 THEN + FAILED ("(B): RESOLUTION INCORRECT " & + "- OPERATOR SYMBOL"); + END IF; + + IF I3 /= -1 OR W3 /= 0 OR + CITRUS'POS (C3) /= 2 OR HUE'POS (H3) /= 1 THEN + FAILED ("(C): RESOLUTION INCORRECT - INFIX " & + "OPERATOR"); + END IF; + + IF CITRUS'POS (C4) /= 2 OR HUE'POS (H4) /= 1 THEN + FAILED ("(D): RESOLUTION INCORRECT - " & + "ENUMERATION LITERAL"); + END IF; + + END E1; + END T1; + + BEGIN + T1.E1; + END; + + RESULT; +END C87B45C; diff --git a/gcc/testsuite/ada/acats/tests/c8/c87b47a.ada b/gcc/testsuite/ada/acats/tests/c8/c87b47a.ada new file mode 100644 index 000000000..c9a426f10 --- /dev/null +++ b/gcc/testsuite/ada/acats/tests/c8/c87b47a.ada @@ -0,0 +1,74 @@ +-- C87B47A.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 OVERLOADING RESOLUTION USES THE RULE THAT: +-- +-- ACTUAL PARAMETERS MUST MATCH THE EXPLICIT TYPEMARK OF THE +-- PARAMETER. + +-- TRH 8 AUG 82 +-- PWN 01/31/95 REMOVED INCONSISTENCIES WITH ADA 9X. + +WITH REPORT; USE REPORT; + +PROCEDURE C87B47A IS + + TYPE FLAG IS (PASS, FAIL); + + GENERIC + TYPE T IS PRIVATE; + ARG : IN T; + STAT : IN FLAG; + FUNCTION F1 RETURN T; + + FUNCTION F1 RETURN T IS + BEGIN + IF STAT = FAIL THEN + FAILED ("ACTUAL PARAMETER MUST MATCH PARAMETER TYPE"); + END IF; + RETURN ARG; + END F1; + + FUNCTION F IS NEW F1 (FLOAT, 2.0, PASS); + FUNCTION F IS NEW F1 (INTEGER, 5, FAIL); + FUNCTION F IS NEW F1 (BOOLEAN, TRUE, FAIL); + FUNCTION F IS NEW F1 (DURATION, 1.0, FAIL); + FUNCTION F IS NEW F1 (CHARACTER, 'E', FAIL); + +BEGIN + TEST ("C87B47A","OVERLOADED ACTUAL PARAMETERS"); + + DECLARE + PROCEDURE P (X : FLOAT) IS + BEGIN + NULL; + END P; + + BEGIN + P (F); + P (X => F); + END; + + RESULT; +END C87B47A; diff --git a/gcc/testsuite/ada/acats/tests/c8/c87b48a.ada b/gcc/testsuite/ada/acats/tests/c8/c87b48a.ada new file mode 100644 index 000000000..d8d79b5c3 --- /dev/null +++ b/gcc/testsuite/ada/acats/tests/c8/c87b48a.ada @@ -0,0 +1,94 @@ +-- C87B48A.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 OVERLOADING RESOLUTION USES THE RULE THAT: +-- +-- NAMED ACTUAL PARAMETERS CAN RESOLVE OVERLOADING OF SUBPROGRAMS. +-- THIS TEST USES FUNCTIONS AND OPERATOR SYMBOLS ONLY. + +-- TRH 13 AUG 82 + +WITH REPORT; USE REPORT; + +PROCEDURE C87B48A IS + + ERR, B1, B2 : BOOLEAN := FALSE; + + PACKAGE A IS + FUNCTION "-" (X : BOOLEAN) RETURN BOOLEAN; + FUNCTION TOGGLE (X : BOOLEAN) RETURN BOOLEAN + RENAMES "-"; + END A; + + PACKAGE BODY A IS + FUNCTION "-" (X : BOOLEAN) RETURN BOOLEAN IS + BEGIN + RETURN NOT X; + END "-"; + END A; + + PACKAGE B IS + FUNCTION "-" (Y : BOOLEAN) RETURN BOOLEAN; + FUNCTION TOGGLE (Y : BOOLEAN) RETURN BOOLEAN + RENAMES "-"; + END B; + + PACKAGE BODY B IS + FUNCTION "-" (Y : BOOLEAN) RETURN BOOLEAN IS + BEGIN + ERR := TRUE; + RETURN NOT Y; + END "-"; + END B; + + PACKAGE C IS + FUNCTION "-" (Z : BOOLEAN) RETURN BOOLEAN; + FUNCTION TOGGLE (Z : BOOLEAN) RETURN BOOLEAN + RENAMES "-"; + END C; + + PACKAGE BODY C IS + FUNCTION "-" (Z : BOOLEAN) RETURN BOOLEAN IS + BEGIN + ERR := TRUE; + RETURN NOT Z; + END "-"; + END C; + + USE A, B, C; + +BEGIN + TEST ("C87B48A","RESOLUTION OF OVERLOADED SUBPROGRAMS BY NAMED " & + "ACTUAL PARAMETERS"); + + B1 := "-" (X => FALSE); + B2 := TOGGLE (X => FALSE); + + IF ERR OR ELSE NOT B1 OR ELSE NOT B2 THEN + FAILED ("RESOLUTION INCORRECT FOR OVERLOADED SUBPROGRAMS" & + " WITH NAMED ACTUAL PARAMETERS"); + END IF; + + RESULT; +END C87B48A; diff --git a/gcc/testsuite/ada/acats/tests/c8/c87b48b.ada b/gcc/testsuite/ada/acats/tests/c8/c87b48b.ada new file mode 100644 index 000000000..45037ecd9 --- /dev/null +++ b/gcc/testsuite/ada/acats/tests/c8/c87b48b.ada @@ -0,0 +1,72 @@ +-- C87B48B.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 OVERLOADING RESOLUTION USES THE RULE THAT: +-- +-- POSITIONAL ACTUAL PARAMETERS CAN RESOLVE OVERLOADING OF SUBPROGRAMS. + +-- TRH 16 AUG 82 + +WITH REPORT; USE REPORT; + +PROCEDURE C87B48B IS + + TYPE FLAG IS (PASS, FAIL); + TYPE INT IS NEW INTEGER; + TYPE BIT IS NEW BOOLEAN; + TYPE WHL IS NEW INTEGER RANGE 0 .. INTEGER'LAST; + + GENERIC + TYPE T1 IS PRIVATE; + TYPE T2 IS PRIVATE; + TYPE T3 IS PRIVATE; + TYPE T4 IS PRIVATE; + STAT : IN FLAG; + PROCEDURE P1 (W : T1; X : T2; Y : T3; Z : T4); + + PROCEDURE P1 (W : T1; X : T2; Y : T3; Z : T4) IS + BEGIN + IF STAT = FAIL THEN + FAILED ("RESOLUTION INCORRECT FOR OVERLOADED SUB" & + "PROGRAMS WITH POSITIONAL ACTUAL PARAMETERS"); + END IF; + END P1; + + PROCEDURE P IS NEW P1 (WHL, INT, WHL, BIT, PASS); + PROCEDURE P IS NEW P1 (WHL, WHL, BIT, INT, FAIL); + PROCEDURE P IS NEW P1 (WHL, INT, BIT, WHL, FAIL); + PROCEDURE P IS NEW P1 (INT, BIT, WHL, WHL, FAIL); + PROCEDURE P IS NEW P1 (BIT, WHL, WHL, INT, FAIL); + PROCEDURE P IS NEW P1 (BIT, INT, WHL, WHL, FAIL); + +BEGIN + TEST ("C87B48B","OVERLOADING RESOLUTION OF SUBPROGRAMS WITH" & + " POSITIONAL ACTUAL PARAMETERS"); + + BEGIN + P (0, 0, 0, TRUE); + END; + + RESULT; +END C87B48B; diff --git a/gcc/testsuite/ada/acats/tests/c8/c87b50a.ada b/gcc/testsuite/ada/acats/tests/c8/c87b50a.ada new file mode 100644 index 000000000..ee287af1d --- /dev/null +++ b/gcc/testsuite/ada/acats/tests/c8/c87b50a.ada @@ -0,0 +1,64 @@ +-- C87B50A.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 FUNCTION RENAMING DECLARATION CAN RESOLVE AND RENAME AN +-- OVERLOADED ENUMERATION LITERAL. + +-- GOM 11/29/84 +-- JWC 7/12/85 +-- PWB 03/06/86 CORRECTED ERROR: ADDED "USE" CLAUSE TO MAKE +-- "/=" VISIBLE. + +WITH REPORT; USE REPORT; +PROCEDURE C87B50A IS + +BEGIN + TEST ("C87B50A", "CHECK THAT A FUNCTION RENAMING DECLARATION " & + "CAN RESOLVE AND RENAME AN OVERLOADED " & + "ENUMERATION LITERAL"); + + DECLARE + + PACKAGE A IS + TYPE COLORS IS (RED,GREEN); + TYPE LIGHT IS (BLUE,RED); + END A; + + PACKAGE B IS + FUNCTION RED RETURN A.COLORS RENAMES A.RED; + FUNCTION GREEN RETURN A.COLORS RENAMES A.GREEN; + END B; + + USE A; -- TO MAKE /= VISIBLE. + + BEGIN + + IF (A.RED /= B.RED) OR (A.GREEN /= B.GREEN) THEN + FAILED ("RENAMED VALUES NOT EQUAL"); + END IF; + + END; + + RESULT; +END C87B50A; diff --git a/gcc/testsuite/ada/acats/tests/c8/c87b54a.ada b/gcc/testsuite/ada/acats/tests/c8/c87b54a.ada new file mode 100644 index 000000000..26b4b1498 --- /dev/null +++ b/gcc/testsuite/ada/acats/tests/c8/c87b54a.ada @@ -0,0 +1,87 @@ +-- C87B54A.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 OVERLOADING RESOLUTION USES THE RULE THAT: +-- +-- THE ARGUMENT OF THE DELAY STATEMENT IS OF THE PREDEFINED FIXED +-- POINT TYPE DURATION. + +-- TRH 7 SEPT 82 + +WITH REPORT; USE REPORT; + +PROCEDURE C87B54A IS + + TYPE TEMPS IS NEW DURATION; + TYPE REAL IS NEW FLOAT; + TYPE TEMPUS IS DELTA 0.1 RANGE -1.0 .. 1.0; + ERR : BOOLEAN := FALSE; + + FUNCTION F (X : TEMPS) RETURN TEMPS IS + BEGIN + ERR := TRUE; + RETURN X; + END F; + + FUNCTION F (X : REAL) RETURN REAL IS + BEGIN + ERR := TRUE; + RETURN X; + END F; + + FUNCTION F (X : TEMPUS) RETURN TEMPUS IS + BEGIN + ERR := TRUE; + RETURN X; + END F; + + FUNCTION F (X : DURATION) RETURN DURATION IS + BEGIN + RETURN X; + END F; + +BEGIN + TEST ("C87B54A","OVERLOADED EXPRESSION WITHIN DELAY STATEMENT"); + + DECLARE + TASK T IS + ENTRY E; + END T; + + TASK BODY T IS + BEGIN + DELAY F (0.0); + DELAY F (1.0); + DELAY F (-1.0); + END T; + + BEGIN + IF ERR THEN FAILED ("DELAY STATEMENT TAKES AN ARGUMENT OF " & + "THE PREDEFINED FIXED POINT TYPE " & + "DURATION"); + END IF; + END; + + RESULT; +END C87B54A; diff --git a/gcc/testsuite/ada/acats/tests/c8/c87b57a.ada b/gcc/testsuite/ada/acats/tests/c8/c87b57a.ada new file mode 100644 index 000000000..31d3b8ad5 --- /dev/null +++ b/gcc/testsuite/ada/acats/tests/c8/c87b57a.ada @@ -0,0 +1,134 @@ +-- C87B57A.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 OVERLOADING RESOLUTION USES THE RULE THAT: +-- +-- FOR A DEFAULT GENERIC IN PARAMETER, THE TYPE OF THE INITIALIZATION +-- EXPRESSION MUST MATCH THE PARAMETERS'S EXPLICIT TYPEMARK. +-- +-- THE FOUR KINDS OF EXPRESSIONS TESTED HERE ARE: +-- +-- (A): A CALL TO AN OVERLOADED FUNCTION. +-- (B): AN OVERLOADED OPERATOR SYMBOL. +-- (C): AN OVERLOADED (INFIX) OPERATOR. +-- (D): AN OVERLOADED ENUMERATION LITERAL. + +-- TRH 25 JUNE 82 + +WITH REPORT; USE REPORT; + +PROCEDURE C87B57A IS + + TYPE WHOLE IS NEW INTEGER RANGE 0..INTEGER'LAST; + TYPE CITRUS IS (LEMON, LIME, ORANGE); + TYPE HUE IS (RED, ORANGE, YELLOW); + + FUNCTION F1 (X, Y : INTEGER) RETURN INTEGER IS + BEGIN + RETURN -1; + END F1; + + FUNCTION F1 (X, Y : WHOLE) RETURN WHOLE IS + BEGIN + RETURN 0; + END F1; + + FUNCTION F1 (X, Y : INTEGER) RETURN HUE IS + BEGIN + RETURN ORANGE; + END F1; + + FUNCTION F1 (X, Y : INTEGER) RETURN CITRUS IS + BEGIN + RETURN ORANGE; + END F1; + +BEGIN + TEST ("C87B57A","OVERLOADED INITIALIZATION EXPRESSIONS" & + " IN DEFAULT GENERIC IN PARAMETERS"); + DECLARE + + FUNCTION "/" (X, Y : INTEGER) RETURN INTEGER + RENAMES F1; + + FUNCTION "/" (X, Y : WHOLE) RETURN WHOLE + RENAMES F1; + + FUNCTION "/" (X, Y : INTEGER) RETURN HUE + RENAMES F1; + + FUNCTION "/" (X, Y : INTEGER) RETURN CITRUS + RENAMES F1; + + GENERIC + I1 : INTEGER := F1 (0, 0); + W1 : WHOLE := F1 (0, 0); + C1 : CITRUS := F1 (0, 0); + H1 : HUE := F1 (0, 0); + I2 : INTEGER := "/" (0, 0); + W2 : WHOLE := "/" (0, 0); + C2 : CITRUS := "/" (0, 0); + H2 : HUE := "/" (0, 0); + I3 : INTEGER := (0 / 0); + W3 : WHOLE := (0 / 0); + C3 : CITRUS := (0 / 0); + H3 : HUE := (0 / 0); + C4 : CITRUS := ORANGE; + H4 : HUE := ORANGE; + + PACKAGE P IS + END P; + + PACKAGE BODY P IS + BEGIN + IF I1 /= -1 OR W1 /= 0 OR + CITRUS'POS (C1) /= 2 OR HUE'POS (H1) /= 1 THEN + FAILED ("(A): RESOLUTION INCORRECT - FUNCTION CALL"); + END IF; + + IF I2 /= -1 OR W2 /= 0 OR + CITRUS'POS (C2) /= 2 OR HUE'POS (H2) /= 1 THEN + FAILED ("(B): RESOLUTION INCORRECT " & + "- OPERATOR SYMBOL"); + END IF; + + IF I3 /= -1 OR W3 /= 0 OR + CITRUS'POS (C3) /= 2 OR HUE'POS (H3) /= 1 THEN + FAILED ("(C): RESOLUTION INCORRECT - INFIX OPERATOR"); + END IF; + + IF CITRUS'POS (C4) /= 2 OR HUE'POS (H4) /= 1 THEN + FAILED ("(D): RESOLUTION INCORRECT - ENUMERATION " & + "LITERAL"); + END IF; + END P; + + PACKAGE P1 IS NEW P; + + BEGIN + NULL; + END; + + RESULT; +END C87B57A; diff --git a/gcc/testsuite/ada/acats/tests/c8/c87b62a.ada b/gcc/testsuite/ada/acats/tests/c8/c87b62a.ada new file mode 100644 index 000000000..550d20bbf --- /dev/null +++ b/gcc/testsuite/ada/acats/tests/c8/c87b62a.ada @@ -0,0 +1,79 @@ +-- C87B62A.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 OVERLOADING RESOLUTION USES THE RULE THAT: +-- +-- IN A LENGTH CLAUSE THAT SPECIFIES 'SIZE, +-- THE EXPRESSION MUST BE OF SOME INTEGER TYPE. + +-- HISTORY: +-- TRH 09/08/82 CREATED ORIGINAL TEST. +-- PWB 02/19/85 ADDED COMMENTS CLARIFYING NON-APPLICABILITY; +-- DELETED TEXT NOT RELATED TO TEST OBJECTIVE. +-- BCB 01/04/88 MODIFIED HEADER. +-- PWB 05/11/89 CHANGED EXTENSION FROM '.DEP' TO '.ADA'. + +WITH REPORT; USE REPORT; + +PROCEDURE C87B62A IS + + TYPE POS_INT IS RANGE 1 .. INTEGER'LAST; + TYPE POS_FIX IS DELTA 0.1 RANGE 0.0 .. 10.0; + ERR : BOOLEAN := FALSE; + + FUNCTION "+" (X : POS_INT) RETURN POS_FIX IS + BEGIN + ERR := TRUE; + RETURN POS_FIX (X); + END "+"; + + FUNCTION "+" (X : POS_FIX) RETURN POS_INT IS + BEGIN + ERR := TRUE; + RETURN POS_INT (X); + END "+"; + +BEGIN + TEST ("C87B62A","OVERLOADED EXPRESSION WITHIN LENGTH CLAUSE " & + "- SPECIFICATION OF ATTRIBUTE T'SIZE"); + + DECLARE + TYPE DECEM IS NEW INTEGER RANGE 1 .. 10; + TYPE JUST_LIKE_DECEM IS NEW INTEGER RANGE 1 .. 10; + DECEM_SIZE : CONSTANT := JUST_LIKE_DECEM'SIZE; + TYPE CHECK IS NEW INTEGER RANGE 1 .. 10; + + FOR CHECK'SIZE USE DECEM_SIZE; + FOR DECEM'SIZE USE + DECEM_SIZE; + + BEGIN + IF ERR THEN + FAILED ("RESOLUTION INCORRECT FOR EXPRESSION IN " & + "LENGTH CLAUSE USING 'SIZE"); + END IF; + END; + + RESULT; +END C87B62A; diff --git a/gcc/testsuite/ada/acats/tests/c8/c87b62b.ada b/gcc/testsuite/ada/acats/tests/c8/c87b62b.ada new file mode 100644 index 000000000..2b03442a5 --- /dev/null +++ b/gcc/testsuite/ada/acats/tests/c8/c87b62b.ada @@ -0,0 +1,99 @@ +-- C87B62B.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 OVERLOADING RESOLUTION USES THE RULE THAT: +-- +-- IN A LENGTH CLAUSE THAT SPECIFIES 'STORAGE_SIZE, +-- THE EXPRESSION MUST BE OF SOME INTEGER TYPE. +-- ACCESS TYPES ARE HERE; TASK TYPES ARE IN C87B62D.DEP. + +-- HISTORY: +-- TRH 09/08/82 CREATED ORIGINAL TEST. +-- EG 06/04/84 +-- PWB 01/19/86 CLARIFIED COMMENTS REGARDING NON-APPLICABILITY; +-- REMOVED TEXT NOT RELATED TO TEST OBJECTIVE +-- MOVED TASK TYPES TO C87B62D.DEP. +-- BCB 01/04/88 MODIFIED HEADER. +-- PWB 05/11/89 CHANGED EXTENSION FROM '.DEP' TO '.ADA'. + +WITH REPORT; USE REPORT; + +PROCEDURE C87B62B IS + + TYPE POS_FIX IS DELTA 0.1 RANGE 0.0 .. 10.0; + TYPE POS_INT IS NEW INTEGER RANGE 0 .. INTEGER'LAST; + TYPE NUMERAL IS NEW CHARACTER RANGE '0' .. '9'; + TYPE BASE_5 IS ('0', '1', '2', '3', '4'); + ERR : BOOLEAN := FALSE; + + FUNCTION F (X : INTEGER) RETURN NUMERAL IS + BEGIN + ERR := TRUE; + RETURN ('9'); + END F; + + FUNCTION F (X : INTEGER) RETURN BASE_5 IS + BEGIN + ERR := TRUE; + RETURN ('4'); + END F; + + FUNCTION F (X : INTEGER) RETURN POS_FIX IS + BEGIN + ERR := TRUE; + RETURN POS_FIX (X); + END F; + + FUNCTION F (X : INTEGER) RETURN POS_INT IS + BEGIN + RETURN POS_INT (X); + END F; + +BEGIN + TEST ("C87B62B","OVERLOADED EXPRESSION WITHIN LENGTH CLAUSE " & + "- SPECIFICATION OF ATTRIBUTE T'STORAGE_SIZE " & + "FOR ACCESS TYPES"); + + DECLARE + + TYPE DECEM IS NEW INTEGER RANGE 1 .. 10; + TYPE LINK IS ACCESS DECEM; + + TYPE JUST_LIKE_LINK IS ACCESS DECEM; + TYPE CHECK IS ACCESS DECEM; + + FOR CHECK'STORAGE_SIZE + USE 1024; + FOR LINK'STORAGE_SIZE USE F (1024); + + BEGIN + IF ERR THEN + FAILED ("RESOLUTION INCORRECT FOR EXPRESSION IN " & + "LENGTH CLAUSE USING 'STORAGE_SIZE"); + END IF; + END; + + RESULT; +END C87B62B; diff --git a/gcc/testsuite/ada/acats/tests/c8/c87b62c.ada b/gcc/testsuite/ada/acats/tests/c8/c87b62c.ada new file mode 100644 index 000000000..fb5d4ef60 --- /dev/null +++ b/gcc/testsuite/ada/acats/tests/c8/c87b62c.ada @@ -0,0 +1,80 @@ +-- C87B62C.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 OVERLOADING RESOLUTION USES THE RULE THAT: +-- +-- IN A LENGTH CLAUSE THAT SPECIFIES 'SMALL, THE EXPRESSION +-- MUST BE OF SOME REAL TYPE. + +-- HISTORY: +-- TRH 09/08/82 CREATED ORIGINAL TEST. +-- PWB 02/19/86 ADDED COMMENTS TO CLARIFY NON-APPLICABILITY; +-- REMOVED TEXT NOT RELATED TO TEST OBJECTIVE. +-- BCB 01/04/88 MODIFIED HEADER. +-- PWB 05/11/89 CHANGED EXTENSION FROM '.DEP' TO '.ADA'. + +WITH REPORT; USE REPORT; + +PROCEDURE C87B62C IS + + TYPE POS_INT IS NEW INTEGER RANGE 1 .. INTEGER'LAST; + TYPE POS_FIX IS DELTA 0.1 RANGE 0.0 .. 10.0; + ERR : BOOLEAN := FALSE; + + FUNCTION "+" (X : POS_INT) RETURN POS_FIX IS + BEGIN + ERR := TRUE; + RETURN POS_FIX (X); + END "+"; + + FUNCTION "+" (X : POS_FIX) RETURN POS_INT IS + BEGIN + ERR := TRUE; + RETURN POS_INT (X); + END "+"; + +BEGIN + TEST ("C87B62C","OVERLOADED EXPRESSION WITHIN LENGTH CLAUSE " & + "- SPECIFICATION OF ATTRIBUTE T'SMALL"); + + DECLARE + TYPE JUST_LIKE_FIXED IS DELTA 0.1 RANGE -1.0 .. 1.0; + TYPE FIXED IS DELTA 0.1 RANGE -1.0 .. 1.0; + + FIKST_SMALL : CONSTANT := JUST_LIKE_FIXED'SMALL; + TYPE CHECK IS DELTA 0.1 RANGE -1.0 .. 1.0; + + FOR CHECK'SMALL USE FIKST_SMALL; + FOR FIXED'SMALL USE + FIKST_SMALL; + + BEGIN + IF ERR THEN + FAILED ("RESOLUTION INCORRECT FOR EXPRESSION IN " & + "LENGTH CLAUSE USING 'SMALL"); + END IF; + END; + + RESULT; +END C87B62C; diff --git a/gcc/testsuite/ada/acats/tests/c8/c87b62d.tst b/gcc/testsuite/ada/acats/tests/c8/c87b62d.tst new file mode 100644 index 000000000..296402a6d --- /dev/null +++ b/gcc/testsuite/ada/acats/tests/c8/c87b62d.tst @@ -0,0 +1,105 @@ +-- C87B62D.TST + +-- 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 OVERLOADING RESOLUTION USES THE RULE THAT: +-- +-- IN A LENGTH CLAUSE THAT SPECIFIES 'STORAGE_SIZE, +-- THE EXPRESSION MUST BE OF SOME INTEGER TYPE. +-- TASK TYPE IS HERE; ACCESS TYPE IS IN C87B62B.DEP. + +-- MACRO SUBSTITUTION: +-- $TASK_STORAGE_SIZE IS THE NUMBER OF STORAGE_UNITS REQUIRED FOR +-- THE ACTIVATION OF A TASK. + +-- HISTORY: +-- TRH 09/08/82 CREATED ORIGINAL TEST. +-- EG 06/04/84 +-- PWB 01/19/86 CREATED THIS TEST FILE FROM THE TASK TYPE PART +-- OF THE OLD C87B62B; +-- CLARIFIED COMMENTS REGARDING NON-APPLICABILITY. +-- BCB 01/04/88 MODIFIED HEADER. +-- PWB 05/11/89 CHANGED EXTENSION FROM '.DEP' TO '.TST'. + +WITH REPORT; USE REPORT; + +PROCEDURE C87B62D IS + + TASK_STORAGE_SIZE : CONSTANT := $TASK_STORAGE_SIZE; + + TYPE POS_INT IS NEW INTEGER RANGE 0 .. INTEGER'LAST; + TYPE POS_FIX IS DELTA 0.1 RANGE 0.0 .. 10.0; + TYPE NUMERAL IS NEW CHARACTER RANGE '0' .. '9'; + TYPE BASE_5 IS ('0', '1', '2', '3', '4'); + ERR : BOOLEAN := FALSE; + + FUNCTION F (X : INTEGER) RETURN NUMERAL IS + BEGIN + ERR := TRUE; + RETURN ('9'); + END F; + + FUNCTION F (X : INTEGER) RETURN BASE_5 IS + BEGIN + ERR := TRUE; + RETURN ('4'); + END F; + + FUNCTION F (X : INTEGER) RETURN POS_FIX IS + BEGIN + ERR := TRUE; + RETURN POS_FIX (X); + END F; + + FUNCTION F (X : INTEGER) RETURN POS_INT IS + BEGIN + RETURN POS_INT (X); + END F; + +BEGIN + TEST ("C87B62D","OVERLOADED EXPRESSION WITHIN LENGTH CLAUSE " & + "- SPECIFICATION OF ATTRIBUTE T'STORAGE_SIZE " & + "FOR TASK TYPES "); + + DECLARE + + TASK TYPE TSK1 IS + END TSK1; + + FOR TSK1'STORAGE_SIZE USE F (TASK_STORAGE_SIZE); + + TASK BODY TSK1 IS + BEGIN + NULL; + END TSK1; + + BEGIN + IF ERR THEN + FAILED ("RESOLUTION INCORRECT FOR EXPRESSION IN " & + "LENGTH CLAUSE USING 'STORAGE_SIZE"); + END IF; + END; + + RESULT; +END C87B62D; |