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/cc | |
| 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/cc')
122 files changed, 24009 insertions, 0 deletions
diff --git a/gcc/testsuite/ada/acats/tests/cc/cc1004a.ada b/gcc/testsuite/ada/acats/tests/cc/cc1004a.ada new file mode 100644 index 000000000..f5a148115 --- /dev/null +++ b/gcc/testsuite/ada/acats/tests/cc/cc1004a.ada @@ -0,0 +1,108 @@ +-- CC1004A.ADA + +-- Grant of Unlimited Rights +-- +-- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687, +-- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained +-- unlimited rights in the software and documentation contained herein. +-- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making +-- this public release, the Government intends to confer upon all +-- recipients unlimited rights equal to those held by the Government. +-- These rights include rights to use, duplicate, release or disclose the +-- released technical data and computer software in whole or in part, in +-- any manner and for any purpose whatsoever, and to have or permit others +-- to do so. +-- +-- DISCLAIMER +-- +-- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR +-- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED +-- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF 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 ELABORATION OF A GENERIC DECLARATION +-- DOES NOT ELABORATE THE SUBPROGRAM OR PACKAGE SPECIFICATION. + +-- HISTORY: +-- DAT 07/31/81 CREATED ORIGINAL TEST. +-- SPS 10/18/82 +-- SPS 02/09/83 +-- JET 01/07/88 UPDATED HEADER FORMAT AND ADDED CODE TO +-- PREVENT OPTIMIZATION. + +WITH REPORT; USE REPORT; + +PROCEDURE CC1004A IS +BEGIN + TEST ("CC1004A", "THE SPECIFICATION PART OF A GENERIC " & + "SUBPROGRAM IS NOT ELABORATED AT THE " & + "ELABORATION OF THE DECLARATION"); + + BEGIN + DECLARE + SUBTYPE I1 IS INTEGER RANGE 1 .. 1; + + GENERIC + PROCEDURE PROC (P1: I1 := IDENT_INT(2)); + + PROCEDURE PROC (P1: I1 := IDENT_INT(2)) IS + BEGIN + IF NOT EQUAL (P1,P1) THEN + COMMENT ("DON'T OPTIMIZE THIS"); + END IF; + END PROC; + BEGIN + BEGIN + DECLARE + PROCEDURE P IS NEW PROC; + BEGIN + IF NOT EQUAL(3,3) THEN + P(1); + END IF; + END; + EXCEPTION + WHEN OTHERS => + FAILED ("INSTANTIATION ELABORATES SPEC"); + END; + + END; + EXCEPTION + WHEN OTHERS => + FAILED ("DECL ELABORATED SPEC PART - 1"); + END; + + BEGIN + DECLARE + SUBTYPE I1 IS INTEGER RANGE 1 .. 1; + + GENERIC + PACKAGE PKG IS + X : INTEGER := I1(IDENT_INT(2)); + END PKG; + BEGIN + BEGIN + DECLARE + PACKAGE P IS NEW PKG; + BEGIN + FAILED ("PACKAGE INSTANTIATION FAILED"); + IF NOT EQUAL(P.X,P.X) THEN + COMMENT("DON'T OPTIMIZE THIS"); + END IF; + END; + EXCEPTION + WHEN CONSTRAINT_ERROR => NULL; + WHEN OTHERS => FAILED ("WRONG EXCEPTION - 2"); + END; + + END; + EXCEPTION + WHEN OTHERS => + FAILED ("DECL ELABORATED SPEC PART - 2"); + END; + + RESULT; + +END CC1004A; diff --git a/gcc/testsuite/ada/acats/tests/cc/cc1005b.ada b/gcc/testsuite/ada/acats/tests/cc/cc1005b.ada new file mode 100644 index 000000000..484227fab --- /dev/null +++ b/gcc/testsuite/ada/acats/tests/cc/cc1005b.ada @@ -0,0 +1,151 @@ +-- CC1005B.ADA + +-- Grant of Unlimited Rights +-- +-- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687, +-- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained +-- unlimited rights in the software and documentation contained herein. +-- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making +-- this public release, the Government intends to confer upon all +-- recipients unlimited rights equal to those held by the Government. +-- These rights include rights to use, duplicate, release or disclose the +-- released technical data and computer software in whole or in part, in +-- any manner and for any purpose whatsoever, and to have or permit others +-- to do so. +-- +-- DISCLAIMER +-- +-- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR +-- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED +-- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF 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 GENERIC UNIT'S IDENTIFIER CAN BE USED IN ITS +-- FORMAL PART: +-- +-- (A) AS THE SELECTOR IN AN EXPANDED NAME TO DENOTE AN ENTITY IN THE +-- VISIBLE PART OF A PACKAGE, OR TO DENOTE AN ENTITY IMMEDIATELY +-- ENCLOSED IN A CONSTRUCT OTHER THAN THE CONSTRUCT IMMEDIATELY +-- ENCLOSING THE GENERIC UNIT. +-- +-- (B) AS A SELECTOR TO DENOTE A COMPONENT OF A RECORD OBJECT, +-- AS THE NAME OF A RECORD OR DISCRIMINANT COMPONENT IN A RECORD +-- AGGREGATE, AND AS THE NAME OF A FORMAL PARAMETER IN A +-- FUNCTION CALL. + +-- HISTORY: +-- BCB 08/03/88 CREATED ORIGINAL TEST. +-- JRL 03/20/92 DELETED TEST IN BLOCK STATEMENT; CONSOLIDATED +-- WITH CC1005C. + +WITH REPORT; USE REPORT; + +PROCEDURE CC1005B IS + + S : INTEGER := IDENT_INT(0); + + PACKAGE CC1005B IS + I : INTEGER; + S : INTEGER := IDENT_INT(5); + GENERIC + S : INTEGER := IDENT_INT(10); + V : INTEGER := STANDARD.CC1005B.S; + W : INTEGER := STANDARD.CC1005B.CC1005B.S; + FUNCTION CC1005B RETURN INTEGER; + END CC1005B; + + PACKAGE BODY CC1005B IS + FUNCTION CC1005B RETURN INTEGER IS + BEGIN + IF NOT EQUAL(V,0) THEN + FAILED ("WRONG VALUE OF S USED IN ASSIGNMENT OF V"); + END IF; + + IF NOT EQUAL(W,5) THEN + FAILED ("WRONG VALUE OF S USED IN ASSIGNMENT OF W"); + END IF; + + RETURN 0; + END CC1005B; + + FUNCTION NEW_CC IS NEW CC1005B; + + BEGIN + TEST ("CC1005B", "CHECK THAT A GENERIC UNIT'S IDENTIFIER " & + "CAN BE USED IN ITS FORMAL PART: AS THE " & + "SELECTOR IN AN EXPANDED NAME TO DENOTE " & + "AN ENTITY IN THE VISIBLE PART OF A " & + "PACKAGE, OR TO DENOTE AN ENTITY " & + "IMMEDIATELY ENCLOSED IN A CONSTRUCT " & + "OTHER THAN THE CONSTRUCT IMMEDIATELY " & + "ENCLOSING THE GENERIC UNIT; AND AS A " & + "SELECTOR TO DENOTE A COMPONENT OF A " & + "RECORD OBJECT, AS THE NAME OF A RECORD " & + "OR DISCRIMINANT COMPONENT IN A RECORD " & + "AGGREGATE, AND AS THE NAME OF A FORMAL " & + "PARAMETER IN A FUNCTION CALL"); + + I := NEW_CC; + END CC1005B; + + FUNCTION F (P : INTEGER) RETURN INTEGER IS + BEGIN + RETURN P; + END F; + +BEGIN + + BLOCK1: + DECLARE + TYPE REC IS RECORD + P : INTEGER := IDENT_INT(0); + END RECORD; + + TYPE REC2 (P : INTEGER) IS RECORD + NULL; + END RECORD; + + R : REC; + + J : INTEGER; + + GENERIC + V : INTEGER := R.P; + X : REC := (P => IDENT_INT(10)); + Y : REC2 := (P => IDENT_INT(15)); + Z : INTEGER := F(P => IDENT_INT(20)); + FUNCTION P RETURN INTEGER; + + FUNCTION P RETURN INTEGER IS + BEGIN + IF NOT EQUAL(V,0) THEN + FAILED ("WRONG VALUE OF P USED IN ASSIGNMENT " & + "OF V"); + END IF; + + IF NOT EQUAL(X.P,10) THEN + FAILED ("WRONG VALUE USED IN ASSIGNMENT OF X.P"); + END IF; + + IF NOT EQUAL(Y.P,15) THEN + FAILED ("WRONG VALUE USED IN ASSIGNMENT OF Y.P"); + END IF; + + IF NOT EQUAL(Z,20) THEN + FAILED ("WRONG VALUE OF P USED IN ASSIGNMENT " & + "OF Z"); + END IF; + + RETURN 0; + END P; + + FUNCTION NEW_P IS NEW P; + BEGIN + J := NEW_P; + END BLOCK1; + + RESULT; +END CC1005B; diff --git a/gcc/testsuite/ada/acats/tests/cc/cc1010a.ada b/gcc/testsuite/ada/acats/tests/cc/cc1010a.ada new file mode 100644 index 000000000..c04a3253c --- /dev/null +++ b/gcc/testsuite/ada/acats/tests/cc/cc1010a.ada @@ -0,0 +1,66 @@ +-- CC1010A.ADA + +-- Grant of Unlimited Rights +-- +-- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687, +-- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained +-- unlimited rights in the software and documentation contained herein. +-- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making +-- this public release, the Government intends to confer upon all +-- recipients unlimited rights equal to those held by the Government. +-- These rights include rights to use, duplicate, release or disclose the +-- released technical data and computer software in whole or in part, in +-- any manner and for any purpose whatsoever, and to have or permit others +-- to do so. +-- +-- DISCLAIMER +-- +-- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR +-- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED +-- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF 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 NAMES IN A GENERIC SUBPROGRAM DECLARATION ARE +-- STATICALLY IDENTIFIED (I.E., BOUND) AT THE POINT WHERE THE +-- GENERIC DECLARATION TEXTUALLY OCCURS, AND ARE NOT DYNAMICALLY +-- BOUND AT THE POINT OF INSTANTIATION. + +-- ASL 8/12/81 + +WITH REPORT; +PROCEDURE CC1010A IS + USE REPORT; +BEGIN + TEST ("CC1010A","PROPER VISIBILITY OF FREE IDENTIFIERS IN " & + "GENERIC DECLARATIONS, BODIES AND INSTANTIATIONS"); + + OUTER: + DECLARE + FREE : CONSTANT INTEGER := 5; + BEGIN + DECLARE + GENERIC + GFP : INTEGER := FREE; + PROCEDURE P(PFP : IN INTEGER := FREE); + + FREE : CONSTANT INTEGER := 6; + + PROCEDURE P(PFP : IN INTEGER := OUTER.FREE) IS + BEGIN + IF FREE /= 6 OR GFP /= 5 OR PFP /= 5 THEN + FAILED ("BINDINGS INCORRECT"); + END IF; + END P; + BEGIN + DECLARE + FREE : CONSTANT INTEGER := 7; + PROCEDURE INST IS NEW P; + BEGIN + INST; + END; + END; + END OUTER; + RESULT; +END CC1010A; diff --git a/gcc/testsuite/ada/acats/tests/cc/cc1010b.ada b/gcc/testsuite/ada/acats/tests/cc/cc1010b.ada new file mode 100644 index 000000000..74ef437b9 --- /dev/null +++ b/gcc/testsuite/ada/acats/tests/cc/cc1010b.ada @@ -0,0 +1,67 @@ +-- CC1010B.ADA + +-- Grant of Unlimited Rights +-- +-- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687, +-- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained +-- unlimited rights in the software and documentation contained herein. +-- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making +-- this public release, the Government intends to confer upon all +-- recipients unlimited rights equal to those held by the Government. +-- These rights include rights to use, duplicate, release or disclose the +-- released technical data and computer software in whole or in part, in +-- any manner and for any purpose whatsoever, and to have or permit others +-- to do so. +-- +-- DISCLAIMER +-- +-- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR +-- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED +-- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF 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 NAMES IN A GENERIC PACKAGE BODY ARE STATICALLY +-- IDENTIFIED (I.E., BOUND) AT THE POINT WHERE THE GENERIC BODY +-- TEXTUALLY OCCURS, AND ARE NOT DYNAMICALLY BOUND AT THE POINT +-- OF INSTANTIATION. + +-- ASL 8/13/81 + +WITH REPORT; +PROCEDURE CC1010B IS + + USE REPORT; + FREE : CONSTANT INTEGER := 5; +BEGIN + TEST("CC1010B","PROPER VISIBILITY OF FREE IDENTIFIERS IN " & + "GENERIC PACKAGE DECLARATIONS, BODIES AND INSTANTIATIONS"); + + DECLARE + GENERIC + GFP : INTEGER := FREE; + PACKAGE P IS + SPECITEM : CONSTANT INTEGER := FREE; + END P; + + FREE : CONSTANT INTEGER := 6; + + PACKAGE BODY P IS + BODYITEM : INTEGER := FREE; + BEGIN + IF GFP /= 5 OR SPECITEM /= 5 OR BODYITEM /= 6 THEN + FAILED ("BINDINGS INCORRECT"); + END IF; + END P; + BEGIN + DECLARE + FREE : CONSTANT INTEGER := 7; + PACKAGE INST IS NEW P; + BEGIN + NULL; + END; + END; + + RESULT; +END CC1010B; diff --git a/gcc/testsuite/ada/acats/tests/cc/cc1018a.ada b/gcc/testsuite/ada/acats/tests/cc/cc1018a.ada new file mode 100644 index 000000000..2ea39a928 --- /dev/null +++ b/gcc/testsuite/ada/acats/tests/cc/cc1018a.ada @@ -0,0 +1,83 @@ +-- CC1018A.ADA + +-- Grant of Unlimited Rights +-- +-- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687, +-- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained +-- unlimited rights in the software and documentation contained herein. +-- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making +-- this public release, the Government intends to confer upon all +-- recipients unlimited rights equal to those held by the Government. +-- These rights include rights to use, duplicate, release or disclose the +-- released technical data and computer software in whole or in part, in +-- any manner and for any purpose whatsoever, and to have or permit others +-- to do so. +-- +-- DISCLAIMER +-- +-- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR +-- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED +-- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF 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 OUT PARAMETER OF A GENERIC FORMAL SUBPROGRAM CAN +-- HAVE A FORMAL LIMITED TYPE AND AN ARRAY TYPE WITH LIMITED COMPONENTS. + +-- AH 10/3/86 + +WITH REPORT; USE REPORT; +PROCEDURE CC1018A IS + TYPE INT IS RANGE 1..10; + TYPE ARR IS ARRAY (INTEGER RANGE <>) OF INT; + INT_OBJ : INT := 4; + ARR_OBJ : ARR(1..5) := (2, 8, 2, 8, 2); + + GENERIC + TYPE GLP IS LIMITED PRIVATE; + TYPE GARR IS ARRAY (INTEGER RANGE <>) OF GLP; + LP_OBJ : IN OUT GLP; + GA_OBJ : IN OUT GARR; + WITH PROCEDURE P (X : OUT GLP; Y : OUT GARR); + WITH FUNCTION SAME (LEFT, RIGHT : GLP) RETURN BOOLEAN; + PROCEDURE GEN_PROC; + + PROCEDURE GET_VALUES (X1 : OUT INT; Y1 : OUT ARR) IS + BEGIN + X1 := 4; + Y1 := (2, 8, 2, 8, 2); + END GET_VALUES; + + FUNCTION SAME_VALUE (LEFT, RIGHT : INT) RETURN BOOLEAN IS + BEGIN + RETURN LEFT = RIGHT; + END SAME_VALUE; + + PROCEDURE GEN_PROC IS + LP : GLP; + A : GARR(1..5); + BEGIN + P(LP, A); + IF NOT SAME(LP, LP_OBJ) THEN + FAILED ("LIMITED PRIVATE TYPE HAS INCORRECT VALUE"); + END IF; + + FOR INDEX IN A'RANGE LOOP + IF NOT SAME(A(INDEX), GA_OBJ(INDEX)) THEN + FAILED ("LIMITED PRIVATE TYPE COMPONENT " & + "HAS INCORRECT VALUE"); + END IF; + END LOOP; + END GEN_PROC; + + PROCEDURE TEST_LP IS NEW GEN_PROC(INT, ARR, INT_OBJ, ARR_OBJ, + GET_VALUES, SAME_VALUE); + +BEGIN + TEST ("CC1018A", "A GENERIC FORMAL SUBPROGRAM OUT PRARAMETER " & + "CAN HAVE A LIMITED TYPE"); + TEST_LP; + + RESULT; +END CC1018A; diff --git a/gcc/testsuite/ada/acats/tests/cc/cc1104c.ada b/gcc/testsuite/ada/acats/tests/cc/cc1104c.ada new file mode 100644 index 000000000..a97e7a097 --- /dev/null +++ b/gcc/testsuite/ada/acats/tests/cc/cc1104c.ada @@ -0,0 +1,151 @@ +-- CC1104C.ADA + +-- Grant of Unlimited Rights +-- +-- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687, +-- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained +-- unlimited rights in the software and documentation contained herein. +-- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making +-- this public release, the Government intends to confer upon all +-- recipients unlimited rights equal to those held by the Government. +-- These rights include rights to use, duplicate, release or disclose the +-- released technical data and computer software in whole or in part, in +-- any manner and for any purpose whatsoever, and to have or permit others +-- to do so. +-- +-- DISCLAIMER +-- +-- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR +-- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED +-- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF 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 GENERIC FORMAL IN OUT PARAMETER CAN HAVE A +-- LIMITED TYPE. + +-- HISTORY: +-- BCB 08/03/88 CREATED ORIGINAL TEST. + +WITH REPORT; USE REPORT; + +PROCEDURE CC1104C IS + + TASK TYPE TSK IS + ENTRY E; + END TSK; + + VAR : INTEGER := IDENT_INT(0); + NEW_VAL : INTEGER := IDENT_INT(5); + + TSK_VAR : TSK; + + PACKAGE PP IS + TYPE LP IS LIMITED PRIVATE; + PROCEDURE INIT (ONE : OUT LP; TWO : INTEGER); + FUNCTION EQUAL (ONE : LP; TWO : INTEGER) RETURN BOOLEAN; + PRIVATE + TYPE LP IS RANGE 1 .. 100; + END PP; + + USE PP; + + TYPE REC IS RECORD + COMP : LP; + END RECORD; + + C : LP; + + REC_VAR : REC; + + GENERIC + TYPE T IS LIMITED PRIVATE; + IN_OUT_VAR : IN OUT T; + IN_OUT_TSK : IN OUT TSK; + VAL : IN OUT T; + WITH PROCEDURE INIT (L : IN OUT T; R : T); + PROCEDURE P; + + GENERIC + VAL : IN OUT LP; + PROCEDURE Q; + + GENERIC + VAL : IN OUT REC; + PROCEDURE R; + + PACKAGE BODY PP IS + PROCEDURE INIT(ONE : OUT LP; TWO : INTEGER) IS + BEGIN + ONE := LP(TWO); + END INIT; + + FUNCTION EQUAL(ONE : LP; TWO : INTEGER) RETURN BOOLEAN IS + BEGIN + RETURN ONE = LP(TWO); + END EQUAL; + END PP; + + TASK BODY TSK IS + BEGIN + ACCEPT E; + END TSK; + + PROCEDURE P IS + BEGIN + INIT(IN_OUT_VAR,VAL); + IN_OUT_TSK.E; + INIT(C,50); + END P; + + PROCEDURE Q IS + BEGIN + INIT(VAL,75); + INIT(REC_VAR.COMP,50); + END Q; + + PROCEDURE R IS + BEGIN + INIT(VAL.COMP,75); + END R; + + PROCEDURE I (ONE : IN OUT INTEGER; TWO : INTEGER) IS + BEGIN + ONE := TWO; + END I; + + PROCEDURE NEW_P IS NEW P(INTEGER,VAR,TSK_VAR,NEW_VAL,I); + + PROCEDURE NEW_Q IS NEW Q(C); + + PROCEDURE NEW_R IS NEW R(REC_VAR); + +BEGIN + TEST ("CC1104C", "CHECK THAT A GENERIC FORMAL IN OUT PARAMETER " & + "CAN HAVE A LIMITED TYPE"); + + NEW_P; + + IF NOT EQUAL(VAR,5) THEN + FAILED ("WRONG VALUE ASSIGNED TO IN OUT PARAMETER IN " & + "GENERIC PACKAGE - 1"); + END IF; + + NEW_Q; + + IF NOT EQUAL(C,75) THEN + FAILED ("WRONG VALUE ASSIGNED TO IN OUT PARAMETER IN " & + "GENERIC PACKAGE - 2"); + END IF; + + NEW_R; + + IF NOT EQUAL(REC_VAR.COMP,75) THEN + FAILED ("WRONG VALUE ASSIGNED TO IN OUT PARAMETER IN " & + "GENERIC PACKAGE - 3"); + END IF; + + RESULT; +END CC1104C; diff --git a/gcc/testsuite/ada/acats/tests/cc/cc1107b.ada b/gcc/testsuite/ada/acats/tests/cc/cc1107b.ada new file mode 100644 index 000000000..94a177615 --- /dev/null +++ b/gcc/testsuite/ada/acats/tests/cc/cc1107b.ada @@ -0,0 +1,84 @@ +-- CC1107B.ADA + +-- Grant of Unlimited Rights +-- +-- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687, +-- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained +-- unlimited rights in the software and documentation contained herein. +-- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making +-- this public release, the Government intends to confer upon all +-- recipients unlimited rights equal to those held by the Government. +-- These rights include rights to use, duplicate, release or disclose the +-- released technical data and computer software in whole or in part, in +-- any manner and for any purpose whatsoever, and to have or permit others +-- to do so. +-- +-- DISCLAIMER +-- +-- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR +-- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED +-- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF 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 DEFAULT EXPRESSION MAY REFER TO AN EARLIER FORMAL +-- PARAMETER OF THE SAME GENERIC FORMAL PART. + +-- HISTORY: +-- BCB 08/03/88 CREATED ORIGINAL TEST. + +WITH REPORT; USE REPORT; + +PROCEDURE CC1107B IS + + J, I : INTEGER; + + X : INTEGER := IDENT_INT(0); + + VAL : INTEGER := IDENT_INT(10); + + GENERIC + X : INTEGER := IDENT_INT(5); + Y : INTEGER := X; + FUNCTION F RETURN INTEGER; + + GENERIC + X : INTEGER; + Y : INTEGER := X; + FUNCTION G RETURN INTEGER; + + FUNCTION F RETURN INTEGER IS + BEGIN + IF NOT EQUAL(X,Y) THEN + FAILED ("WRONG VALUE FROM EARLIER FORMAL PARAMETER - 1"); + END IF; + + RETURN 0; + END F; + + FUNCTION G RETURN INTEGER IS + BEGIN + IF NOT EQUAL(X,Y) THEN + FAILED ("WRONG VALUE FROM EARLIER FORMAL PARAMETER - 2"); + END IF; + + RETURN 0; + END G; + + FUNCTION NEW_F IS NEW F; + + FUNCTION NEW_G IS NEW G(VAL); + +BEGIN + TEST ("CC1107B", "CHECK THAT A DEFAULT EXPRESSION MAY REFER " & + "TO AN EARLIER FORMAL PARAMETER OF THE SAME " & + "GENERIC FORMAL PART"); + + J := NEW_F; + + I := NEW_G; + + RESULT; +END CC1107B; diff --git a/gcc/testsuite/ada/acats/tests/cc/cc1111a.ada b/gcc/testsuite/ada/acats/tests/cc/cc1111a.ada new file mode 100644 index 000000000..709307d13 --- /dev/null +++ b/gcc/testsuite/ada/acats/tests/cc/cc1111a.ada @@ -0,0 +1,322 @@ +-- CC1111A.ADA + +-- Grant of Unlimited Rights +-- +-- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687, +-- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained +-- unlimited rights in the software and documentation contained herein. +-- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making +-- this public release, the Government intends to confer upon all +-- recipients unlimited rights equal to those held by the Government. +-- These rights include rights to use, duplicate, release or disclose the +-- released technical data and computer software in whole or in part, in +-- any manner and for any purpose whatsoever, and to have or permit others +-- to do so. +-- +-- DISCLAIMER +-- +-- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR +-- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED +-- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF 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 AFTER A GENERIC UNIT IS INSTANTIATED, THE SUBTYPE OF +-- AN IN OUT OBJECT PARAMETER IS DETERMINED BY THE ACTUAL PARAMETER +-- (TESTS INTEGER, ENUMERATION, FLOATING POINT, FIXED POINT, ARRAY, +-- ACCESS, AND DISCRIMINATED TYPES). + +-- HISTORY: +-- BCB 03/28/88 CREATED ORIGINAL TEST. +-- PWN 01/31/95 REMOVED INCONSISTENCIES WITH ADA 9X. + +WITH REPORT; USE REPORT; + +PROCEDURE CC1111A IS + + SUBTYPE INT IS INTEGER RANGE 0..5; + INTVAR : INTEGER RANGE 1..3; + + TYPE ENUM IS (ONE, TWO, THREE, FOUR, FIVE, SIX, SEVEN, EIGHT); + SUBTYPE SUBENUM IS ENUM RANGE ONE .. FIVE; + ENUMVAR : ENUM RANGE TWO .. THREE; + + TYPE FLT IS DIGITS 5 RANGE -5.0 .. 5.0; + SUBTYPE SUBFLT IS FLT RANGE -1.0 .. 1.0; + FLTVAR : FLT RANGE 0.0 .. 1.0; + + TYPE FIX IS DELTA 0.5 RANGE -5.0 .. 5.0; + SUBTYPE SUBFIX IS FIX RANGE -1.0 .. 1.0; + FIXVAR : FIX RANGE 0.0 .. 1.0; + + SUBTYPE STR IS STRING (1..10); + STRVAR : STRING (1..5); + + TYPE REC (DISC : INTEGER := 5) IS RECORD + NULL; + END RECORD; + SUBTYPE SUBREC IS REC (6); + RECVAR : REC(5); + SUBRECVAR : SUBREC; + + TYPE ACCREC IS ACCESS REC; + SUBTYPE A1 IS ACCREC(1); + SUBTYPE A2 IS ACCREC(2); + A1VAR : A1 := NEW REC(1); + A2VAR : A2 := NEW REC(2); + + PACKAGE P IS + TYPE PRIV IS PRIVATE; + PRIVATE + TYPE PRIV IS RANGE 1 .. 100; + SUBTYPE SUBPRIV IS PRIV RANGE 5 .. 10; + PRIVVAR : PRIV RANGE 8 .. 10; + END P; + + PACKAGE BODY P IS + FUNCTION PRIVEQUAL (ONE, TWO : SUBPRIV) RETURN BOOLEAN; + + FUNCTION PRIVEQUAL (ONE, TWO : SUBPRIV) RETURN BOOLEAN IS + BEGIN + RETURN ONE = TWO; + END PRIVEQUAL; + + GENERIC + INPUT : SUBPRIV; + OUTPUT : IN OUT SUBPRIV; + PROCEDURE I; + + PROCEDURE I IS + BEGIN + OUTPUT := INPUT; + FAILED ("SUBTYPE NOT DETERMINED BY ACTUAL PARAMETER - " & + "PRIVATE TYPE"); + IF PRIVEQUAL (OUTPUT, OUTPUT) THEN + COMMENT ("DON'T OPTIMIZE OUTPUT"); + END IF; + EXCEPTION + WHEN CONSTRAINT_ERROR => + NULL; + WHEN OTHERS => + FAILED ("WRONG EXCEPTION RAISED"); + END I; + + PROCEDURE I1 IS NEW I (5, PRIVVAR); + PROCEDURE I2 IS NEW I (SUBPRIV'FIRST, PRIVVAR); + + BEGIN + TEST ("CC1111A", "CHECK THAT AFTER A GENERIC UNIT IS " & + "INSTANTIATED, THE SUBTYPE OF AN IN OUT " & + "OBJECT PARAMETER IS DETERMINED BY THE " & + "ACTUAL PARAMETER (TESTS INTEGER, " & + "ENUMERATION, FLOATING POINT, FIXED POINT " & + ", ARRAY, ACCESS, AND DISCRIMINATED TYPES)"); + + I1; + I2; + END P; + + USE P; + + GENERIC + TYPE GP IS PRIVATE; + FUNCTION GEN_IDENT (X : GP) RETURN GP; + + GENERIC + INPUT : INT; + OUTPUT : IN OUT INT; + PROCEDURE B; + + GENERIC + INPUT : SUBENUM; + OUTPUT : IN OUT SUBENUM; + PROCEDURE C; + + GENERIC + INPUT : SUBFLT; + OUTPUT : IN OUT SUBFLT; + PROCEDURE D; + + GENERIC + INPUT : SUBFIX; + OUTPUT : IN OUT SUBFIX; + PROCEDURE E; + + GENERIC + INPUT : STR; + OUTPUT : IN OUT STR; + PROCEDURE F; + + GENERIC + INPUT : A1; + OUTPUT : IN OUT A1; + PROCEDURE G; + + GENERIC + INPUT : SUBREC; + OUTPUT : IN OUT SUBREC; + PROCEDURE H; + + GENERIC + TYPE GP IS PRIVATE; + FUNCTION GENEQUAL (ONE, TWO : GP) RETURN BOOLEAN; + + FUNCTION GENEQUAL (ONE, TWO : GP) RETURN BOOLEAN IS + BEGIN + RETURN ONE = TWO; + END GENEQUAL; + + FUNCTION GEN_IDENT (X : GP) RETURN GP IS + BEGIN + RETURN X; + END GEN_IDENT; + + FUNCTION INT_IDENT IS NEW GEN_IDENT (INT); + FUNCTION SUBENUM_IDENT IS NEW GEN_IDENT (SUBENUM); + FUNCTION SUBFLT_IDENT IS NEW GEN_IDENT (SUBFLT); + FUNCTION SUBFIX_IDENT IS NEW GEN_IDENT (SUBFIX); + + FUNCTION ENUMEQUAL IS NEW GENEQUAL (SUBENUM); + FUNCTION FLTEQUAL IS NEW GENEQUAL (SUBFLT); + FUNCTION FIXEQUAL IS NEW GENEQUAL (SUBFIX); + FUNCTION STREQUAL IS NEW GENEQUAL (STR); + FUNCTION ACCEQUAL IS NEW GENEQUAL (A2); + FUNCTION RECEQUAL IS NEW GENEQUAL (REC); + + PROCEDURE B IS + BEGIN + OUTPUT := INPUT; + FAILED ("SUBTYPE NOT DETERMINED BY ACTUAL PARAMETER - " & + "INTEGER TYPE"); + IF EQUAL (OUTPUT, OUTPUT) THEN + COMMENT ("DON'T OPTIMIZE OUTPUT"); + END IF; + EXCEPTION + WHEN CONSTRAINT_ERROR => + NULL; + WHEN OTHERS => + FAILED ("WRONG EXCEPTION RAISED"); + END B; + + PROCEDURE C IS + BEGIN + OUTPUT := INPUT; + FAILED ("SUBTYPE NOT DETERMINED BY ACTUAL PARAMETER - " & + "ENUMERATION TYPE"); + IF ENUMEQUAL (OUTPUT, OUTPUT) THEN + COMMENT ("DON'T OPTIMIZE OUTPUT"); + END IF; + EXCEPTION + WHEN CONSTRAINT_ERROR => + NULL; + WHEN OTHERS => + FAILED ("WRONG EXCEPTION RAISED"); + END C; + + PROCEDURE D IS + BEGIN + OUTPUT := INPUT; + FAILED ("SUBTYPE NOT DETERMINED BY ACTUAL PARAMETER - " & + "FLOATING POINT TYPE"); + IF FLTEQUAL (OUTPUT, OUTPUT) THEN + COMMENT ("DON'T OPTIMIZE OUTPUT"); + END IF; + EXCEPTION + WHEN CONSTRAINT_ERROR => + NULL; + WHEN OTHERS => + FAILED ("WRONG EXCEPTION RAISED"); + END D; + + PROCEDURE E IS + BEGIN + OUTPUT := INPUT; + FAILED ("SUBTYPE NOT DETERMINED BY ACTUAL PARAMETER - " & + "FIXED POINT TYPE"); + IF FIXEQUAL (OUTPUT, OUTPUT) THEN + COMMENT ("DON'T OPTIMIZE OUTPUT"); + END IF; + EXCEPTION + WHEN CONSTRAINT_ERROR => + NULL; + WHEN OTHERS => + FAILED ("WRONG EXCEPTION RAISED"); + END E; + + PROCEDURE F IS + BEGIN + OUTPUT := INPUT; + FAILED ("SUBTYPE NOT DETERMINED BY ACTUAL PARAMETER - " & + "ARRAY TYPE"); + IF STREQUAL (OUTPUT, OUTPUT) THEN + COMMENT ("DON'T OPTIMIZE OUTPUT"); + END IF; + EXCEPTION + WHEN CONSTRAINT_ERROR => + NULL; + WHEN OTHERS => + FAILED ("WRONG EXCEPTION RAISED"); + END F; + + PROCEDURE G IS + BEGIN + OUTPUT := INPUT; + FAILED ("SUBTYPE NOT DETERMINED BY ACTUAL PARAMETER - " & + "ACCESS TYPE"); + IF ACCEQUAL (OUTPUT, OUTPUT) THEN + COMMENT ("DON'T OPTIMIZE OUTPUT"); + END IF; + EXCEPTION + WHEN CONSTRAINT_ERROR => + NULL; + WHEN OTHERS => + FAILED ("WRONG EXCEPTION RAISED"); + END G; + + PROCEDURE H IS + BEGIN + OUTPUT := INPUT; + FAILED ("SUBTYPE NOT DETERMINED BY ACTUAL PARAMETER - " & + "DISCRIMINATED RECORD TYPE"); + IF RECEQUAL (OUTPUT, OUTPUT) THEN + COMMENT ("DON'T OPTIMIZE OUTPUT"); + END IF; + EXCEPTION + WHEN CONSTRAINT_ERROR => + NULL; + WHEN OTHERS => + FAILED ("WRONG EXCEPTION RAISED"); + END H; + + PROCEDURE B1 IS NEW B (4, INTVAR); + PROCEDURE C1 IS NEW C (FOUR, ENUMVAR); + PROCEDURE D1 IS NEW D (-1.0, FLTVAR); + PROCEDURE E1 IS NEW E (-1.0, FIXVAR); + PROCEDURE F1 IS NEW F ("9876543210", STRVAR); + PROCEDURE G1 IS NEW G (A1VAR, A2VAR); + PROCEDURE H1 IS NEW H (SUBRECVAR, RECVAR); + + PROCEDURE B2 IS NEW B (INT_IDENT(INT'FIRST), INTVAR); + PROCEDURE C2 IS NEW C (SUBENUM_IDENT(SUBENUM'FIRST), ENUMVAR); + PROCEDURE D2 IS NEW D (SUBFLT_IDENT(SUBFLT'FIRST), FLTVAR); + PROCEDURE E2 IS NEW E (SUBFIX_IDENT(SUBFIX'FIRST), FIXVAR); + +BEGIN + + B1; + C1; + D1; + E1; + F1; + G1; + H1; + + B2; + C2; + D2; + E2; + + RESULT; +END CC1111A; diff --git a/gcc/testsuite/ada/acats/tests/cc/cc1204a.ada b/gcc/testsuite/ada/acats/tests/cc/cc1204a.ada new file mode 100644 index 000000000..17e3d7f0f --- /dev/null +++ b/gcc/testsuite/ada/acats/tests/cc/cc1204a.ada @@ -0,0 +1,115 @@ +-- CC1204A.ADA + +-- Grant of Unlimited Rights +-- +-- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687, +-- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained +-- unlimited rights in the software and documentation contained herein. +-- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making +-- this public release, the Government intends to confer upon all +-- recipients unlimited rights equal to those held by the Government. +-- These rights include rights to use, duplicate, release or disclose the +-- released technical data and computer software in whole or in part, in +-- any manner and for any purpose whatsoever, and to have or permit others +-- to do so. +-- +-- DISCLAIMER +-- +-- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR +-- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED +-- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF 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 GENERIC FORMAL TYPES MAY HAVE A DISCRIMINANT PART, +-- WHICH MAY BE OF A GENERIC FORMAL TYPE. + +-- DAT 8/14/81 +-- SPS 5/12/82 + +WITH REPORT; USE REPORT; + +PROCEDURE CC1204A IS +BEGIN + TEST ("CC1204A", "DISCRIMINANT PARTS FOR GENERIC FORMAL TYPES"); + + DECLARE + GENERIC + TYPE T IS ( <> ); + TYPE I IS RANGE <> ; + TYPE R1 (C : BOOLEAN) IS PRIVATE; + TYPE R2 (C : T) IS PRIVATE; + TYPE R3 (C : I) IS LIMITED PRIVATE; + P1 : IN R1; + P2 : IN R2; + V1 : IN OUT R1; + V2 : IN OUT R2; + V3 : IN OUT R3; + PROCEDURE PROC; + + TYPE DD IS NEW INTEGER RANGE 1 .. 10; + TYPE ARR IS ARRAY (DD RANGE <>) OF CHARACTER; + TYPE RECD (C : DD := DD (IDENT_INT (1))) IS + RECORD + C1 : ARR (1..C); + END RECORD; + + X1 : RECD; + X2 : RECD := (1, "Y"); + + TYPE RECB (C : BOOLEAN) IS + RECORD + V : INTEGER := 6; + END RECORD; + RB : RECB (IDENT_BOOL (TRUE)); + RB1 : RECB (IDENT_BOOL (TRUE)); + + PROCEDURE PROC IS + BEGIN + IF P1.C /= TRUE + OR P2.C /= T'FIRST + OR V1.C /= TRUE + OR V2.C /= T'FIRST + OR V3.C /= I'FIRST + THEN + FAILED ("WRONG GENERIC PARAMETER VALUE"); + END IF; + + V1 := P1; + V2 := P2; + + IF V1 /= P1 + OR V2 /= P2 + THEN + FAILED ("BAD ASSIGNMENT TO GENERIC PARAMETERS"); + END IF; + END PROC; + + BEGIN + RB1.V := IDENT_INT (1); + X1.C1 := "X"; + + DECLARE + + PROCEDURE PR IS NEW PROC + (T => DD, + I => DD, + R1 => RECB, + R2 => RECD, + R3 => RECD, + P1 => RB1, + P2 => X1, + V1 => RB, + V2 => X2, + V3 => X2); + BEGIN + PR; + IF RB /= (TRUE, 1) OR X2.C1 /= "X" THEN + FAILED ("PR NOT CALLED CORRECTLY"); + END IF; + END; + END; + + RESULT; +END CC1204A; diff --git a/gcc/testsuite/ada/acats/tests/cc/cc1207b.ada b/gcc/testsuite/ada/acats/tests/cc/cc1207b.ada new file mode 100644 index 000000000..b8eeae495 --- /dev/null +++ b/gcc/testsuite/ada/acats/tests/cc/cc1207b.ada @@ -0,0 +1,138 @@ +-- CC1207B.ADA + +-- Grant of Unlimited Rights +-- +-- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687, +-- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained +-- unlimited rights in the software and documentation contained herein. +-- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making +-- this public release, the Government intends to confer upon all +-- recipients unlimited rights equal to those held by the Government. +-- These rights include rights to use, duplicate, release or disclose the +-- released technical data and computer software in whole or in part, in +-- any manner and for any purpose whatsoever, and to have or permit others +-- to do so. +-- +-- DISCLAIMER +-- +-- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR +-- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED +-- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF 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 UNCONSTRAINED FORMAL TYPE WITH DISCRIMINANTS IS +-- ALLOWED AS THE TYPE OF A SUBPROGRAM OR AN ENTRY FORMAL +-- PARAMETER, AND AS THE TYPE OF A GENERIC FORMAL OBJECT PARAMETER, +-- AS A GENERIC ACTUAL PARAMETER, AND IN A MEMBERSHIP TEST, IN A +-- SUBTYPE DECLARATION, IN AN ACCESS TYPE DEFINITION, AND IN A +-- DERIVED TYPE DEFINITION. + +-- HISTORY: +-- BCB 08/04/88 CREATED ORIGINAL TEST. + +WITH REPORT; USE REPORT; + +PROCEDURE CC1207B IS + + GENERIC + TYPE X (L : INTEGER) IS PRIVATE; + PACKAGE PACK IS + END PACK; + +BEGIN + TEST ("CC1207B", "CHECK THAT AN UNCONSTRAINED FORMAL TYPE WITH " & + "DISCRIMINANTS IS ALLOWED AS THE TYPE OF A " & + "SUBPROGRAM OR AN ENTRY FORMAL PARAMETER, AND " & + "AS THE TYPE OF A GENERIC FORMAL OBJECT " & + "PARAMETER, AS A GENERIC ACTUAL PARAMETER, AND " & + "IN A MEMBERSHIP TEST, IN A SUBTYPE " & + "DECLARATION, IN AN ACCESS TYPE DEFINITION, " & + "AND IN A DERIVED TYPE DEFINITION"); + + DECLARE + TYPE REC (D : INTEGER := 3) IS RECORD + NULL; + END RECORD; + + GENERIC + TYPE R (D : INTEGER) IS PRIVATE; + OBJ : R; + PACKAGE P IS + PROCEDURE S (X : R); + + TASK T IS + ENTRY E (Y : R); + END T; + + SUBTYPE SUB_R IS R; + + TYPE ACC_R IS ACCESS R; + + TYPE NEW_R IS NEW R; + + BOOL : BOOLEAN := (OBJ IN R); + + SUB_VAR : SUB_R(5); + + ACC_VAR : ACC_R := NEW R(5); + + NEW_VAR : NEW_R(5); + + PACKAGE NEW_PACK IS NEW PACK (R); + END P; + + REC_VAR : REC(5) := (D => 5); + + PACKAGE BODY P IS + PROCEDURE S (X : R) IS + BEGIN + IF NOT EQUAL(X.D,5) THEN + FAILED ("WRONG DISCRIMINANT VALUE - S"); + END IF; + END S; + + TASK BODY T IS + BEGIN + ACCEPT E (Y : R) DO + IF NOT EQUAL(Y.D,5) THEN + FAILED ("WRONG DISCRIMINANT VALUE - T"); + END IF; + END E; + END T; + BEGIN + IF NOT EQUAL(OBJ.D,5) THEN + FAILED ("IMPROPER DISCRIMINANT VALUE"); + END IF; + + S (OBJ); + + T.E (OBJ); + + IF NOT EQUAL(SUB_VAR.D,5) THEN + FAILED ("IMPROPER DISCRIMINANT VALUE - SUBTYPE"); + END IF; + + IF NOT EQUAL(ACC_VAR.D,5) THEN + FAILED ("IMPROPER DISCRIMINANT VALUE - ACCESS"); + END IF; + + IF NOT EQUAL(NEW_VAR.D,5) THEN + FAILED ("IMPROPER DISCRIMINANT VALUE - DERIVED"); + END IF; + + IF NOT BOOL THEN + FAILED ("IMPROPER RESULT FROM MEMBERSHIP TEST"); + END IF; + END P; + + PACKAGE NEW_P IS NEW P (REC,REC_VAR); + + BEGIN + NULL; + END; + + RESULT; +END CC1207B; diff --git a/gcc/testsuite/ada/acats/tests/cc/cc1220a.ada b/gcc/testsuite/ada/acats/tests/cc/cc1220a.ada new file mode 100644 index 000000000..cabd5911a --- /dev/null +++ b/gcc/testsuite/ada/acats/tests/cc/cc1220a.ada @@ -0,0 +1,174 @@ +-- CC1220A.ADA + +-- Grant of Unlimited Rights +-- +-- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687, +-- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained +-- unlimited rights in the software and documentation contained herein. +-- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making +-- this public release, the Government intends to confer upon all +-- recipients unlimited rights equal to those held by the Government. +-- These rights include rights to use, duplicate, release or disclose the +-- released technical data and computer software in whole or in part, in +-- any manner and for any purpose whatsoever, and to have or permit others +-- to do so. +-- +-- DISCLAIMER +-- +-- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR +-- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED +-- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF 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 GENERIC UNIT CAN REFER TO AN IMPLICITLY +-- DECLARED PREDEFINED OPERATOR. + +-- HISTORY: +-- DAT 08/20/81 CREATED ORIGINAL TEST. +-- SPS 05/03/82 +-- BCB 08/04/88 MODIFIED HEADER FORMAT AND ADDED CHECKS FOR OTHER +-- OPERATIONS OF A DISCRETE TYPE. +-- RJW 03/27/90 REVISED TEST TO CHECK FOR A GENERIC FORMAL +-- DISCRETE TYPE. +-- CJJ 10/14/90 ADDED CHECKS FOR RELATIONAL OPERATOR (<, <=, >, >=); +-- MADE FAILED MESSAGES IN PROCEDURE BODY MORE SPECIFIC. + +WITH REPORT; USE REPORT; +WITH SYSTEM; USE SYSTEM; + +PROCEDURE CC1220A IS + +BEGIN + TEST ("CC1220A", "GENERIC UNIT CAN REFER TO IMPLICITLY " & + "DECLARED OPERATORS"); + + + DECLARE + + GENERIC + TYPE T IS (<>); + STR : STRING; + P1 : T := T'FIRST; + P2 : T := T(T'SUCC (P1)); + P3 : T := T'(T'PRED (P2)); + P4 : INTEGER := IDENT_INT(T'WIDTH); + P5 : BOOLEAN := (P1 < P2) AND (P2 > P3); + P6: BOOLEAN := (P1 <= P3) AND (P2 >= P1); + P7 : BOOLEAN := (P3 = P1); + P8 : T := T'BASE'FIRST; + P10 : T := T'LAST; + P11 : INTEGER := T'SIZE; + P12 : ADDRESS := P10'ADDRESS; + P13 : INTEGER := T'WIDTH; + P14 : INTEGER := T'POS(T'LAST); + P15 : T := T'VAL(1); + P16 : INTEGER := T'POS(P15); + P17 : STRING := T'IMAGE(T'BASE'LAST); + P18 : T := T'VALUE(P17); + P19 : BOOLEAN := (P15 IN T); + WITH FUNCTION IDENT (X : T) RETURN T; + PACKAGE PKG IS + ARR : ARRAY (1 .. 3) OF T := (P1,P2,P3); + B1 : BOOLEAN := P7 AND P19; + B2 : BOOLEAN := P5 AND P6; + END PKG; + + PACKAGE BODY PKG IS + BEGIN + IF P1 /= T(T'FIRST) THEN + FAILED ("IMPROPER VALUE FOR 'FIRST - " & STR); + END IF; + + IF T'SUCC (P1) /= IDENT (P2) OR + T'PRED (P2) /= IDENT (P1) THEN + FAILED ("IMPROPER VALUE FOR 'SUCC, PRED - " & STR); + END IF; + + IF P10 /= T(T'LAST) THEN + FAILED ("IMPROPER VALUE FOR 'LAST - " & STR); + END IF; + + IF NOT EQUAL(P11,T'SIZE) THEN + FAILED ("IMPROPER VALUE FOR 'SIZE - " & STR); + END IF; + + IF NOT EQUAL(P13,T'WIDTH) THEN + FAILED ("IMPROPER VALUE FOR 'WIDTH - " & STR); + END IF; + + IF NOT EQUAL (P16, T'POS (P15)) OR + T'VAL (P16) /= T(IDENT (P15)) THEN + FAILED ("IMPROPER VALUE FOR 'POS, 'VAL - " & STR); + END IF; + + IF T'VALUE (P17) /= T'BASE'LAST OR + T'IMAGE (P18) /= T'IMAGE (T'BASE'LAST) THEN + FAILED ("IMPROPER VALUE FOR 'VALUE, 'IMAGE - " & + STR); + END IF; + END PKG; + + BEGIN + DECLARE + TYPE CHAR IS ('A', 'B', 'C', 'D', 'E'); + + FUNCTION IDENT (C : CHAR) RETURN CHAR IS + BEGIN + RETURN CHAR'VAL (IDENT_INT (CHAR'POS (C))); + END IDENT; + + PACKAGE N_CHAR IS NEW PKG (T => CHAR, STR => "CHAR", + IDENT => IDENT); + BEGIN + IF N_CHAR.ARR (1) /= IDENT ('A') OR + N_CHAR.ARR (2) /= IDENT ('B') OR + N_CHAR.ARR (3) /= 'A' OR + N_CHAR.B1 /= TRUE OR + N_CHAR.B2 /= TRUE THEN + FAILED ("IMPROPER VALUES FOR ARRAY COMPONENTS" & + " IN INSTANTIATION OF N_CHAR."); + END IF; + END; + + DECLARE + TYPE ENUM IS (JOVIAL, ADA, FORTRAN, BASIC); + + FUNCTION IDENT (C : ENUM) RETURN ENUM IS + BEGIN + RETURN ENUM'VAL (IDENT_INT (ENUM'POS (C))); + END IDENT; + + PACKAGE N_ENUM IS NEW PKG (T => ENUM, STR => "ENUM", + IDENT => IDENT); + + BEGIN + IF N_ENUM.ARR (1) /= IDENT (JOVIAL) OR + N_ENUM.ARR (2) /= IDENT (ADA) OR + N_ENUM.ARR (3) /= JOVIAL OR + N_ENUM.B1 /= TRUE OR + N_ENUM.B2 /= TRUE THEN + FAILED ("IMPROPER VALUES FOR ARRAY COMPONENTS" & + " IN INSTANTIATION OF N_ENUM."); + END IF; + END; + + DECLARE + + PACKAGE N_INT IS NEW PKG (T => INTEGER, STR => "INTEGER", + IDENT => IDENT_INT); + BEGIN + IF N_INT.ARR (1) /= IDENT_INT (INTEGER'FIRST) OR + N_INT.ARR (2) /= IDENT_INT (INTEGER'FIRST + 1) OR + N_INT.ARR (3) /= INTEGER'FIRST OR + N_INT.B1 /= TRUE OR + N_INT.B2 /= TRUE THEN + FAILED ("IMPROPER VALUES FOR ARRAY COMPONENTS" & + " IN INSTANTIATION OF N_INT."); + END IF; + END; + END; + RESULT; +END CC1220A; diff --git a/gcc/testsuite/ada/acats/tests/cc/cc1221a.ada b/gcc/testsuite/ada/acats/tests/cc/cc1221a.ada new file mode 100644 index 000000000..0749e86f3 --- /dev/null +++ b/gcc/testsuite/ada/acats/tests/cc/cc1221a.ada @@ -0,0 +1,141 @@ +-- CC1221A.ADA + +-- Grant of Unlimited Rights +-- +-- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687, +-- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained +-- unlimited rights in the software and documentation contained herein. +-- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making +-- this public release, the Government intends to confer upon all +-- recipients unlimited rights equal to those held by the Government. +-- These rights include rights to use, duplicate, release or disclose the +-- released technical data and computer software in whole or in part, in +-- any manner and for any purpose whatsoever, and to have or permit others +-- to do so. +-- +-- DISCLAIMER +-- +-- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR +-- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED +-- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF 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: +-- FOR A FORMAL INTEGER TYPE, CHECK THAT THE FOLLOWING BASIC +-- OPERATIONS ARE IMPLICITLY DECLARED AND ARE THEREFORE AVAILABLE +-- WITHIN THE GENERIC UNIT: ASSIGNMENT, MEMBERSHIP, QUALIFICATION, +-- AND EXPLICIT CONVERSION TO AND FROM OTHER INTEGER TYPES. + +-- HISTORY: +-- RJW 09/26/86 CREATED ORIGINAL TEST. +-- BCB 11/12/87 CHANGED HEADER TO STANDARD FORMAT. SPLIT TEST +-- INTO PARTS A, B, C, AND D. + +WITH SYSTEM; USE SYSTEM; +WITH REPORT; USE REPORT; +PROCEDURE CC1221A IS + + SUBTYPE SUBINT IS INTEGER RANGE -100 .. 100; + TYPE NEWINT IS NEW INTEGER; + TYPE INT IS RANGE -300 .. 300; + +BEGIN + TEST ( "CC1221A", "FOR A FORMAL INTEGER TYPE, CHECK THAT THE " & + "FOLLOWING BASIC OPERATIONS ARE IMPLICITLY " & + "DECLARED AND ARE THEREFORE AVAILABLE " & + "WITHIN THE GENERIC UNIT: ASSIGNMENT, " & + "MEMBERSHIP, QUALIFICATION, AND EXPLICIT " & + "CONVERSION TO AND FROM OTHER INTEGER TYPES"); + + DECLARE -- (A) CHECKS FOR BASIC OPERATIONS OF A DISCRETE TYPE. + -- PART I. + + GENERIC + TYPE T IS RANGE <>; + TYPE T1 IS RANGE <>; + I : T; + I1 : T1; + PROCEDURE P (J : T; STR : STRING); + + PROCEDURE P (J : T; STR : STRING) IS + SUBTYPE ST IS T RANGE T'VAL (-1) .. T'VAL (1); + K, L : T; + + FUNCTION F (X : T) RETURN BOOLEAN IS + BEGIN + RETURN IDENT_BOOL (TRUE); + END F; + + FUNCTION F (X : T1) RETURN BOOLEAN IS + BEGIN + RETURN IDENT_BOOL (FALSE); + END F; + + BEGIN + K := I; + L := J; + K := L; + + IF K /= J THEN + FAILED ( "INCORRECT RESULTS FOR ASSIGNMENT " & + "WITH TYPE - " & STR); + END IF; + + IF I IN ST THEN + NULL; + ELSE + FAILED ( "INCORRECT RESULTS FOR ""IN"" WITH " & + "TYPE - " & STR); + END IF; + + IF J NOT IN ST THEN + NULL; + ELSE + FAILED ( "INCORRECT RESULTS FOR ""NOT IN"" WITH " & + "TYPE - " & STR); + END IF; + + IF T'(I) /= I THEN + FAILED ( "INCORRECT RESULTS FOR QUALIFICATION " & + "WITH TYPE - " & STR & " - 1" ); + END IF; + + IF F (T'(1)) THEN + NULL; + ELSE + FAILED ( "INCORRECT RESULTS FOR QUALIFICATION " & + "WITH TYPE - " & STR & " - 2" ); + END IF; + + IF T (I1) /= I THEN + FAILED ( "INCORRECT RESULTS FOR EXPLICIT " & + "CONVERSION WITH TYPE - " & STR & + " - 1" ); + END IF; + + IF F (T (I1)) THEN + NULL; + ELSE + FAILED ( "INCORRECT RESULTS FOR EXPLICIT " & + "CONVERSION WITH TYPE - " & STR & + " - 2" ); + END IF; + + END P; + + PROCEDURE NP1 IS NEW P (SUBINT, SUBINT, 0, 0); + PROCEDURE NP2 IS NEW P (NEWINT, NEWINT, 0, 0); + PROCEDURE NP3 IS NEW P (INT, INT, 0, 0); + PROCEDURE NP4 IS NEW P (INTEGER, INTEGER, 0, 0); + + BEGIN + NP1 (2, "SUBINT"); + NP2 (2, "NEWINT"); + NP3 (2, "INT"); + NP4 (2, "INTEGER"); + END; -- (A). + + RESULT; +END CC1221A; diff --git a/gcc/testsuite/ada/acats/tests/cc/cc1221b.ada b/gcc/testsuite/ada/acats/tests/cc/cc1221b.ada new file mode 100644 index 000000000..2e4d816d4 --- /dev/null +++ b/gcc/testsuite/ada/acats/tests/cc/cc1221b.ada @@ -0,0 +1,159 @@ +-- CC1221B.ADA + +-- Grant of Unlimited Rights +-- +-- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687, +-- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained +-- unlimited rights in the software and documentation contained herein. +-- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making +-- this public release, the Government intends to confer upon all +-- recipients unlimited rights equal to those held by the Government. +-- These rights include rights to use, duplicate, release or disclose the +-- released technical data and computer software in whole or in part, in +-- any manner and for any purpose whatsoever, and to have or permit others +-- to do so. +-- +-- DISCLAIMER +-- +-- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR +-- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED +-- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF 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: +-- FOR A FORMAL INTEGER TYPE, CHECK THAT THE FOLLOWING BASIC +-- OPERATIONS ARE IMPLICITLY DECLARED AND ARE THEREFORE AVAILABLE +-- WITHIN THE GENERIC UNIT: ATTRIBUTES 'FIRST, 'LAST, 'WIDTH, +-- 'ADDRESS, AND 'SIZE. + +-- HISTORY: +-- BCB 11/12/87 CREATED ORIGINAL TEST FROM SPLIT OF CC1221A.ADA. + +WITH SYSTEM; USE SYSTEM; +WITH REPORT; USE REPORT; +PROCEDURE CC1221B IS + + SUBTYPE SUBINT IS INTEGER RANGE -100 .. 100; + SUBTYPE NOINT IS INTEGER RANGE 1 .. -1; + TYPE NEWINT IS NEW INTEGER; + TYPE INT IS RANGE -300 .. 300; + SUBTYPE SINT1 IS INT + RANGE INT (IDENT_INT (-4)) .. INT (IDENT_INT (4)); + SUBTYPE SINT2 IS INT RANGE 16#E#E1 .. 2#1111_1111#; + TYPE INT2 IS RANGE 0E8 .. 1E3; + +BEGIN + TEST ( "CC1221B", "FOR A FORMAL INTEGER TYPE, CHECK THAT THE " & + "FOLLOWING BASIC OPERATIONS ARE IMPLICITLY " & + "DECLARED AND ARE THEREFORE AVAILABLE " & + "WITHIN THE GENERIC UNIT: ATTRIBUTES 'FIRST, " & + "'LAST, 'WIDTH, 'ADDRESS, AND 'SIZE"); + + DECLARE -- (B) CHECKS FOR BASIC OPERATIONS OF A DISCRETE TYPE. + -- PART II. + + GENERIC + TYPE T IS RANGE <>; + F, L : T; + W : INTEGER; + PROCEDURE P (STR : STRING); + + PROCEDURE P (STR : STRING) IS + I : INTEGER := F'SIZE; + T1 : T; + A : ADDRESS := T1'ADDRESS; + + BEGIN + IF T'FIRST /= F THEN + FAILED ( "INCORRECT VALUE FOR " & STR & "'FIRST" ); + END IF; + + IF T'LAST /= L THEN + FAILED ( "INCORRECT VALUE FOR " & STR & "'LAST" ); + END IF; + + IF T'BASE'FIRST > T'FIRST THEN + FAILED ( "INCORRECT RESULTS WITH " & STR & + "'BASE'FIRST" ); + END IF; + + IF T'BASE'LAST < T'LAST THEN + FAILED ( "INCORRECT RESULTS WITH " & STR & + "'BASE'LAST" ); + END IF; + + IF T'WIDTH /= W THEN + FAILED ( "INCORRECT VALUE FOR " & STR & + "'WIDTH" ); + END IF; + + IF T'BASE'WIDTH < T'WIDTH THEN + FAILED ( "INCORRECT RESULTS WITH " & STR & + "'BASE'WIDTH" ); + END IF; + + END P; + + GENERIC + TYPE T IS RANGE <>; + PROCEDURE Q; + + PROCEDURE Q IS + BEGIN + IF T'FIRST /= 1 THEN + FAILED ( "INCORRECT VALUE FOR NOINT'FIRST" ); + END IF; + + IF T'LAST /= -1 THEN + FAILED ( "INCORRECT VALUE FOR NOINT'LAST" ); + END IF; + + IF T'BASE'FIRST > T'FIRST THEN + FAILED ( "INCORRECT RESULTS WITH " & + "NOINT'BASE'FIRST" ); + END IF; + + IF T'BASE'LAST < T'LAST THEN + FAILED ( "INCORRECT RESULTS WITH " & + "NOINT'BASE'LAST" ); + END IF; + + IF T'WIDTH /= 0 THEN + FAILED ( "INCORRECT VALUE FOR " & + "NOINT'WIDTH" ); + END IF; + + IF T'BASE'WIDTH < T'WIDTH THEN + FAILED ( "INCORRECT RESULTS WITH " & + "NOINT'BASE'WIDTH" ); + END IF; + + END Q; + + PROCEDURE P1 IS NEW P (INTEGER, INTEGER'FIRST, INTEGER'LAST, + INTEGER'WIDTH); + PROCEDURE P2 IS NEW P (SUBINT, -100, 100, 4); + PROCEDURE P3 IS NEW P (NEWINT, NEWINT'FIRST, NEWINT'LAST, + NEWINT'WIDTH); + PROCEDURE P4 IS NEW P (SINT1, -4, 4, 2); + PROCEDURE P5 IS NEW P (SINT2, 224, 255, 4); + PROCEDURE P6 IS NEW P (INT2 , 0, 1000, 5); + + PROCEDURE Q1 IS NEW Q (NOINT); + + BEGIN + P1 ( "INTEGER" ); + P2 ( "SUBINT" ); + P3 ( "NEWINT" ); + P4 ( "SINT1" ); + P5 ( "SINT2" ); + P6 ( "INT2" ); + + Q1; + + END; -- (B). + + RESULT; +END CC1221B; diff --git a/gcc/testsuite/ada/acats/tests/cc/cc1221c.ada b/gcc/testsuite/ada/acats/tests/cc/cc1221c.ada new file mode 100644 index 000000000..21738858e --- /dev/null +++ b/gcc/testsuite/ada/acats/tests/cc/cc1221c.ada @@ -0,0 +1,195 @@ +-- CC1221C.ADA + +-- Grant of Unlimited Rights +-- +-- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687, +-- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained +-- unlimited rights in the software and documentation contained herein. +-- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making +-- this public release, the Government intends to confer upon all +-- recipients unlimited rights equal to those held by the Government. +-- These rights include rights to use, duplicate, release or disclose the +-- released technical data and computer software in whole or in part, in +-- any manner and for any purpose whatsoever, and to have or permit others +-- to do so. +-- +-- DISCLAIMER +-- +-- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR +-- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED +-- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF 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: +-- FOR A FORMAL INTEGER TYPE, CHECK THAT THE FOLLOWING BASIC +-- OPERATIONS ARE IMPLICITLY DECLARED AND ARE THEREFORE AVAILABLE +-- WITHIN THE GENERIC UNIT: ATTRIBUTES 'POS, 'VAL, 'PRED, 'SUCC, +-- 'IMAGE, AND 'VALUE. + +-- HISTORY: +-- BCB 11/12/87 CREATED ORIGINAL TEST FROM SPLIT OF CC1221A.ADA + +WITH SYSTEM; USE SYSTEM; +WITH REPORT; USE REPORT; +PROCEDURE CC1221C IS + + SUBTYPE SUBINT IS INTEGER RANGE -100 .. 100; + TYPE NEWINT IS NEW INTEGER; + TYPE INT IS RANGE -300 .. 300; + SUBTYPE SINT1 IS INT + RANGE INT (IDENT_INT (-4)) .. INT (IDENT_INT (4)); + TYPE INT1 IS RANGE -6 .. 6; + +BEGIN + TEST ( "CC1221C", "FOR A FORMAL INTEGER TYPE, CHECK THAT THE " & + "FOLLOWING BASIC OPERATIONS ARE IMPLICITLY " & + "DECLARED AND ARE THEREFORE AVAILABLE " & + "WITHIN THE GENERIC UNIT: ATTRIBUTES 'POS, " & + "'VAL, 'PRED, 'SUCC, 'IMAGE, AND 'VALUE"); + + DECLARE -- (C1) CHECKS FOR BASIC OPERATIONS OF A DISCRETE TYPE. + -- PART III. + + GENERIC + TYPE T IS RANGE <>; + F : INTEGER; + PROCEDURE P (STR : STRING); + + PROCEDURE P (STR : STRING) IS + I : INTEGER; + Y : T; + + FUNCTION IDENT (X : T) RETURN T IS + BEGIN + IF EQUAL (3, 3) THEN + RETURN X; + ELSE + RETURN T'SUCC (T'FIRST); + END IF; + END IDENT; + + BEGIN + I := F; + FOR X IN T LOOP + IF T'VAL (I) /= X THEN + FAILED ( "WRONG VALUE FOR " & STR & + "'VAL OF " & INTEGER'IMAGE (I)); + END IF; + + IF T'POS (X) /= I THEN + FAILED ( "WRONG VALUE FOR " & STR & + "'POS OF " & T'IMAGE (X)); + END IF; + + I := I + 1; + END LOOP; + + FOR X IN T LOOP + IF T'SUCC (X) /= T'VAL (T'POS (X) + 1) THEN + FAILED ( "WRONG VALUE FOR " & STR & + "'SUCC OF " & T'IMAGE (X)); + END IF; + + IF T'PRED (X) /= T'VAL (T'POS (X) - 1) THEN + FAILED ( "WRONG VALUE FOR " & STR & + "'PRED OF " & T'IMAGE (X)); + END IF; + END LOOP; + + BEGIN + Y := T'SUCC (IDENT (T'BASE'LAST)); + FAILED ( "NO EXCEPTION RAISED FOR " & + STR & "'SUCC (IDENT (" & STR & + "'BASE'LAST))" ); + EXCEPTION + WHEN CONSTRAINT_ERROR => + NULL; + WHEN OTHERS => + FAILED ( "WRONG EXCEPTION RAISED FOR " & + STR & "'SUCC (IDENT (" & STR & + "'BASE'LAST))" ); + END; + + BEGIN + Y := T'PRED (IDENT (T'BASE'FIRST)); + FAILED ( "NO EXCEPTION RAISED FOR " & + STR & "'PRED (IDENT (" & STR & + "'BASE'FIRST))" ); + EXCEPTION + WHEN CONSTRAINT_ERROR => + NULL; + WHEN OTHERS => + FAILED ( "WRONG EXCEPTION RAISED FOR " & + STR & "'PRED (IDENT (" & STR & + "'BASE'FIRST))" ); + END; + + END P; + + PROCEDURE P1 IS NEW P (SUBINT, -100); + PROCEDURE P2 IS NEW P (SINT1, -4); + PROCEDURE P3 IS NEW P (INT1, -6); + + BEGIN + P1 ( "SUBINT" ); + P2 ( "SINT" ); + P3 ( "INT1" ); + END; -- (C1). + + DECLARE -- (C2) CHECKS FOR BASIC OPERATIONS OF A DISCRETE TYPE. + -- PART IV. + + GENERIC + TYPE T IS RANGE <>; + STR : STRING; + PACKAGE PKG IS END PKG; + + PACKAGE BODY PKG IS + PROCEDURE P (IM : STRING; VA : T) IS + BEGIN + IF T'IMAGE (VA) /= IM THEN + FAILED ( "INCORRECT RESULTS FOR " & STR & + "'IMAGE OF " & + INTEGER'IMAGE (INTEGER (VA))); + END IF; + END P; + + PROCEDURE Q (IM : STRING; VA : T) IS + BEGIN + IF T'VALUE (IM) /= VA THEN + FAILED ( "INCORRECT RESULTS FOR " & STR & + "'VALUE OF " & IM); + END IF; + EXCEPTION + WHEN CONSTRAINT_ERROR => + FAILED ( "CONSTRAINT_ERROR RAISED FOR " & + STR &"'VALUE OF " & IM); + WHEN OTHERS => + FAILED ( "OTHER EXCEPTION RAISED FOR " & + STR &"'VALUE OF " & IM); + + END Q; + + BEGIN + P (" 2", 2); + P ("-1", -1); + + Q (" 2", 2); + Q ("-1", -1); + Q (" 2", 2); + Q ("-1 ", -1); + END PKG; + + PACKAGE PKG1 IS NEW PKG (SUBINT, "SUBINT"); + PACKAGE PKG2 IS NEW PKG (SINT1, "SINT1"); + PACKAGE PKG3 IS NEW PKG (INT1, "INT1"); + PACKAGE PKG4 IS NEW PKG (NEWINT, "NEWINT"); + + BEGIN + NULL; + END; -- (C2). + + RESULT; +END CC1221C; diff --git a/gcc/testsuite/ada/acats/tests/cc/cc1221d.ada b/gcc/testsuite/ada/acats/tests/cc/cc1221d.ada new file mode 100644 index 000000000..931d01627 --- /dev/null +++ b/gcc/testsuite/ada/acats/tests/cc/cc1221d.ada @@ -0,0 +1,173 @@ +-- CC1221D.ADA + +-- Grant of Unlimited Rights +-- +-- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687, +-- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained +-- unlimited rights in the software and documentation contained herein. +-- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making +-- this public release, the Government intends to confer upon all +-- recipients unlimited rights equal to those held by the Government. +-- These rights include rights to use, duplicate, release or disclose the +-- released technical data and computer software in whole or in part, in +-- any manner and for any purpose whatsoever, and to have or permit others +-- to do so. +-- +-- DISCLAIMER +-- +-- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR +-- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED +-- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF 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: +-- FOR A FORMAL INTEGER TYPE, CHECK THAT THE FOLLOWING BASIC +-- OPERATIONS ARE IMPLICITLY DECLARED AND ARE THEREFORE AVAILABLE +-- WITHIN THE GENERIC UNIT: EXPLICIT CONVERSION TO AND FROM REAL +-- TYPES AND IMPLICIT CONVERSION FROM INTEGER LITERALS. + +-- HISTORY: +-- BCB 11/12/87 CREATED ORIGINAL TEST FROM SPLIT OF CC1221A.ADA + +WITH SYSTEM; USE SYSTEM; +WITH REPORT; USE REPORT; +PROCEDURE CC1221D IS + + SUBTYPE SUBINT IS INTEGER RANGE -100 .. 100; + TYPE INT IS RANGE -300 .. 300; + SUBTYPE SINT1 IS INT + RANGE INT (IDENT_INT (-4)) .. INT (IDENT_INT (4)); + TYPE INT1 IS RANGE -6 .. 6; + +BEGIN + TEST ( "CC1221D", "FOR A FORMAL INTEGER TYPE, CHECK THAT THE " & + "FOLLOWING BASIC OPERATIONS ARE IMPLICITLY " & + "DECLARED AND ARE THEREFORE AVAILABLE " & + "WITHIN THE GENERIC UNIT: EXPLICIT " & + "CONVERSION TO AND FROM REAL TYPES AND " & + "IMPLICIT CONVERSION FROM INTEGER LITERALS"); + + DECLARE -- (D) CHECKS FOR EXPLICIT CONVERSION TO AND FROM OTHER + -- NUMERIC TYPES, AND IMPLICIT CONVERSION FROM + -- INTEGER LITERALS. + + GENERIC + TYPE T IS RANGE <>; + PROCEDURE P (STR : STRING); + + PROCEDURE P (STR : STRING) IS + + TYPE FIXED IS DELTA 0.1 RANGE -100.0 .. 100.0; + FI0 : FIXED := 0.0; + FI2 : FIXED := 2.0; + FIN2 : FIXED := -2.0; + + FL0 : FLOAT := 0.0; + FL2 : FLOAT := 2.0; + FLN2 : FLOAT := -2.0; + + T0 : T := 0; + T2 : T := 2; + TN2 : T := -2; + + FUNCTION IDENT (X : T) RETURN T IS + BEGIN + IF EQUAL (3, 3) THEN + RETURN X; + ELSE + RETURN T'FIRST; + END IF; + END IDENT; + + BEGIN + IF T0 + 1 /= 1 THEN + FAILED ( "INCORRECT RESULTS FOR IMPLICIT " & + "CONVERSION WITH TYPE " & STR & " - 1" ); + END IF; + + IF T2 + 1 /= 3 THEN + FAILED ( "INCORRECT RESULTS FOR IMPLICIT " & + "CONVERSION WITH TYPE " & STR & " - 2" ); + END IF; + + IF TN2 + 1 /= -1 THEN + FAILED ( "INCORRECT RESULTS FOR IMPLICIT " & + "CONVERSION WITH TYPE " & STR & " - 3" ); + END IF; + + IF T (FI0) /= T0 THEN + FAILED ( "INCORRECT CONVERSION FROM " & + "FIXED VALUE 0.0 WITH TYPE " & STR); + END IF; + + IF T (FI2) /= IDENT (T2) THEN + FAILED ( "INCORRECT CONVERSION FROM " & + "FIXED VALUE 2.0 WITH TYPE " & STR); + END IF; + + IF T (FIN2) /= TN2 THEN + FAILED ( "INCORRECT CONVERSION FROM " & + "FIXED VALUE -2.0 WITH TYPE " & STR); + END IF; + + IF T (FL0) /= IDENT (T0) THEN + FAILED ( "INCORRECT CONVERSION FROM " & + "FLOAT VALUE 0.0 WITH TYPE " & STR); + END IF; + + IF T (FL2) /= T2 THEN + FAILED ( "INCORRECT CONVERSION FROM " & + "FLOAT VALUE 2.0 WITH TYPE " & STR); + END IF; + + IF T (FLN2) /= IDENT (TN2) THEN + FAILED ( "INCORRECT CONVERSION FROM " & + "FLOAT VALUE -2.0 WITH TYPE " & STR); + END IF; + + IF FIXED (T0) /= FI0 THEN + FAILED ( "INCORRECT CONVERSION TO " & + "FIXED VALUE 0.0 WITH TYPE " & STR); + END IF; + + IF FIXED (IDENT (T2)) /= FI2 THEN + FAILED ( "INCORRECT CONVERSION TO " & + "FIXED VALUE 2.0 WITH TYPE " & STR); + END IF; + + IF FIXED (TN2) /= FIN2 THEN + FAILED ( "INCORRECT CONVERSION TO " & + "FIXED VALUE -2.0 WITH TYPE " & STR); + END IF; + + IF FLOAT (IDENT (T0)) /= FL0 THEN + FAILED ( "INCORRECT CONVERSION TO " & + "FLOAT VALUE 0.0 WITH TYPE " & STR); + END IF; + + IF FLOAT (T2) /= FL2 THEN + FAILED ( "INCORRECT CONVERSION TO " & + "FLOAT VALUE 2.0 WITH TYPE " & STR); + END IF; + + IF FLOAT (IDENT (TN2)) /= FLN2 THEN + FAILED ( "INCORRECT CONVERSION TO " & + "FLOAT VALUE -2.0 WITH TYPE " & STR); + END IF; + + END P; + + PROCEDURE P1 IS NEW P (SUBINT); + PROCEDURE P2 IS NEW P (SINT1); + PROCEDURE P3 IS NEW P (INT1); + + BEGIN + P1 ( "SUBINT" ); + P2 ( "SINT" ); + P3 ( "INT1" ); + END; -- (D). + + RESULT; +END CC1221D; diff --git a/gcc/testsuite/ada/acats/tests/cc/cc1222a.ada b/gcc/testsuite/ada/acats/tests/cc/cc1222a.ada new file mode 100644 index 000000000..f6f65896c --- /dev/null +++ b/gcc/testsuite/ada/acats/tests/cc/cc1222a.ada @@ -0,0 +1,290 @@ +-- CC1222A.ADA + +-- Grant of Unlimited Rights +-- +-- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687, +-- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained +-- unlimited rights in the software and documentation contained herein. +-- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making +-- this public release, the Government intends to confer upon all +-- recipients unlimited rights equal to those held by the Government. +-- These rights include rights to use, duplicate, release or disclose the +-- released technical data and computer software in whole or in part, in +-- any manner and for any purpose whatsoever, and to have or permit others +-- to do so. +-- +-- DISCLAIMER +-- +-- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR +-- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED +-- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE +-- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE +-- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A +-- PARTICULAR PURPOSE OF SAID MATERIAL. +--* +-- FOR A FORMAL FLOATING POINT TYPE, CHECK THAT THE FOLLOWING BASIC +-- OPERATIONS ARE IMPLICITLY DECLARED AND ARE THEREFORE AVAILABLE +-- WITHIN THE GENERIC UNIT: ASSIGNMENT, MEMBERSHIP TESTS, +-- QUALIFICATION, EXPLICIT CONVERSION TO AND FROM OTHER NUMERIC TYPES, +-- AND REAL LITERALS (IMPLICIT CONVERSION FROM UNIVERSAL REAL TO THE +-- FORMAL TYPE), 'FIRST, 'LAST, 'SIZE, 'ADDRESS, 'DIGITS, 'MACHINE_RADIX, +-- 'MACHINE_MANTISSA, 'MACHINE_EMAX, 'MACHINE_EMIN, 'MACHINE_ROUNDS, +-- 'MACHINE_OVERFLOWS. + +-- R.WILLIAMS 9/30/86 +-- PWN 01/31/95 REMOVED INCONSISTENCIES WITH ADA 9X. + +WITH REPORT; USE REPORT; +WITH SYSTEM; USE SYSTEM; +PROCEDURE CC1222A IS + + TYPE NEWFLT IS NEW FLOAT; + +BEGIN + TEST ( "CC1222A", "FOR A FORMAL FLOATING POINT TYPE, CHECK " & + "THAT THE BASIC OPERATIONS ARE " & + "IMPLICITLY DECLARED AND ARE THEREFORE " & + "AVAILABLE WITHIN THE GENERIC UNIT" ); + + DECLARE -- (A). CHECKS FOR ASSIGNMENT, MEMBERSHIP TESTS AND + -- QUALIFICATION. + + GENERIC + TYPE T IS DIGITS <>; + TYPE T1 IS DIGITS <>; + F : T; + F1 : T1; + PROCEDURE P (F2 : T; STR : STRING); + + PROCEDURE P (F2 : T; STR : STRING) IS + SUBTYPE ST IS T RANGE -1.0 .. 1.0; + F3, F4 : T; + + FUNCTION FUN (X : T) RETURN BOOLEAN IS + BEGIN + RETURN IDENT_BOOL (TRUE); + END FUN; + + FUNCTION FUN (X : T1) RETURN BOOLEAN IS + BEGIN + RETURN IDENT_BOOL (FALSE); + END FUN; + + BEGIN + F3 := F; + F4 := F2; + F3 := F4; + + IF F3 /= F2 THEN + FAILED ( "INCORRECT RESULTS FOR ASSIGNMENT " & + "WITH TYPE - " & STR); + END IF; + + IF F IN ST THEN + NULL; + ELSE + FAILED ( "INCORRECT RESULTS FOR ""IN"" WITH " & + "TYPE - " & STR); + END IF; + + IF F2 NOT IN ST THEN + NULL; + ELSE + FAILED ( "INCORRECT RESULTS FOR ""NOT IN"" WITH " & + "TYPE - " & STR); + END IF; + + IF T'(F) /= F THEN + FAILED ( "INCORRECT RESULTS FOR QUALIFICATION " & + "WITH TYPE - " & STR & " - 1" ); + END IF; + + IF FUN (T'(1.0)) THEN + NULL; + ELSE + FAILED ( "INCORRECT RESULTS FOR QUALIFICATION " & + "WITH TYPE - " & STR & " - 2" ); + END IF; + + END P; + + PROCEDURE P1 IS NEW P (FLOAT, FLOAT, 0.0, 0.0); + PROCEDURE P2 IS NEW P (NEWFLT, NEWFLT, 0.0, 0.0); + + BEGIN + P1 (2.0, "FLOAT"); + P2 (2.0, "NEWFLT"); + END; -- (A). + + DECLARE -- (B) CHECKS FOR EXPLICIT CONVERSION TO AND FROM OTHER + -- NUMERIC TYPES, AND IMPLICIT CONVERSION FROM + -- REAL LITERAL. + + GENERIC + TYPE T IS DIGITS <>; + PROCEDURE P (STR : STRING); + + PROCEDURE P (STR : STRING) IS + + TYPE FIXED IS DELTA 0.1 RANGE -100.0 .. 100.0; + FI0 : FIXED := 0.0; + FI2 : FIXED := 2.0; + FIN2 : FIXED := -2.0; + + I0 : INTEGER := 0; + I2 : INTEGER := 2; + IN2 : INTEGER := -2; + + T0 : T := 0.0; + T2 : T := 2.0; + TN2 : T := -2.0; + + FUNCTION IDENT (X : T) RETURN T IS + BEGIN + IF EQUAL (3, 3) THEN + RETURN X; + ELSE + RETURN T'FIRST; + END IF; + END IDENT; + + BEGIN + IF T0 + 1.0 /= 1.0 THEN + FAILED ( "INCORRECT RESULTS FOR IMPLICIT " & + "CONVERSION WITH TYPE " & STR & " - 1" ); + END IF; + + IF T2 + 1.0 /= 3.0 THEN + FAILED ( "INCORRECT RESULTS FOR IMPLICIT " & + "CONVERSION WITH TYPE " & STR & " - 2" ); + END IF; + + IF TN2 + 1.0 /= -1.0 THEN + FAILED ( "INCORRECT RESULTS FOR IMPLICIT " & + "CONVERSION WITH TYPE " & STR & " - 3" ); + END IF; + + IF T (FI0) /= T0 THEN + FAILED ( "INCORRECT CONVERSION FROM " & + "FIXED VALUE 0.0 WITH TYPE " & STR); + END IF; + + IF T (FI2) /= IDENT (T2) THEN + FAILED ( "INCORRECT CONVERSION FROM " & + "FIXED VALUE 2.0 WITH TYPE " & STR); + END IF; + + IF T (FIN2) /= TN2 THEN + FAILED ( "INCORRECT CONVERSION FROM " & + "FIXED VALUE -2.0 WITH TYPE " & STR); + END IF; + + IF T (I0) /= IDENT (T0) THEN + FAILED ( "INCORRECT CONVERSION FROM " & + "INTEGER VALUE 0 WITH TYPE " & STR); + END IF; + + IF T (I2) /= T2 THEN + FAILED ( "INCORRECT CONVERSION FROM " & + "INTEGER VALUE 2 WITH TYPE " & STR); + END IF; + + IF T (IN2) /= IDENT (TN2) THEN + FAILED ( "INCORRECT CONVERSION FROM " & + "INTEGER VALUE -2 WITH TYPE " & STR); + END IF; + + IF FIXED (T0) /= FI0 THEN + FAILED ( "INCORRECT CONVERSION TO " & + "FIXED VALUE 0.0 WITH TYPE " & STR); + END IF; + + IF FIXED (IDENT (T2)) /= FI2 THEN + FAILED ( "INCORRECT CONVERSION TO " & + "FIXED VALUE 2.0 WITH TYPE " & STR); + END IF; + + IF FIXED (TN2) /= FIN2 THEN + FAILED ( "INCORRECT CONVERSION TO " & + "FIXED VALUE -2.0 WITH TYPE " & STR); + END IF; + + IF INTEGER (IDENT (T0)) /= I0 THEN + FAILED ( "INCORRECT CONVERSION TO " & + "INTEGER VALUE 0 WITH TYPE " & STR); + END IF; + + IF INTEGER (T2) /= I2 THEN + FAILED ( "INCORRECT CONVERSION TO " & + "INTEGER VALUE 2 WITH TYPE " & STR); + END IF; + + IF INTEGER (IDENT (TN2)) /= IN2 THEN + FAILED ( "INCORRECT CONVERSION TO " & + "INTEGER VALUE -2 WITH TYPE " & STR); + END IF; + + END P; + + PROCEDURE P1 IS NEW P (FLOAT); + PROCEDURE P2 IS NEW P (NEWFLT); + + BEGIN + P1 ( "FLOAT" ); + P2 ( "NEWFLT" ); + END; -- (B). + + DECLARE -- (C) CHECKS FOR ATTRIBUTES. + + GENERIC + TYPE T IS DIGITS <>; + F, L : T; + D : INTEGER; + PROCEDURE P (STR : STRING); + + PROCEDURE P (STR : STRING) IS + + F1 : T; + A : ADDRESS := F'ADDRESS; + S : INTEGER := F'SIZE; + + I : INTEGER; + I1 : INTEGER := T'MACHINE_RADIX; + I2 : INTEGER := T'MACHINE_MANTISSA; + I3 : INTEGER := T'MACHINE_EMAX; + I4 : INTEGER := T'MACHINE_EMIN; + + B1 : BOOLEAN := T'MACHINE_ROUNDS; + B2 : BOOLEAN := T'MACHINE_OVERFLOWS; + + BEGIN + IF T'DIGITS /= D THEN + FAILED ( "INCORRECT VALUE FOR " & + STR & "'DIGITS" ); + END IF; + + IF T'FIRST /= F THEN + FAILED ( "INCORRECT VALUE FOR " & + STR & "'FIRST" ); + END IF; + + IF T'LAST /= L THEN + FAILED ( "INCORRECT VALUE FOR " & + STR & "'LAST" ); + END IF; + + END P; + + PROCEDURE P1 IS + NEW P (FLOAT, FLOAT'FIRST, FLOAT'LAST, FLOAT'DIGITS); + PROCEDURE P2 IS + NEW P (NEWFLT, NEWFLT'FIRST, NEWFLT'LAST, + NEWFLT'DIGITS); + + BEGIN + P1 ( "FLOAT" ); + P2 ( "NEWFLT" ); + END; -- (C). + + RESULT; +END CC1222A; diff --git a/gcc/testsuite/ada/acats/tests/cc/cc1223a.ada b/gcc/testsuite/ada/acats/tests/cc/cc1223a.ada new file mode 100644 index 000000000..1f9b0052f --- /dev/null +++ b/gcc/testsuite/ada/acats/tests/cc/cc1223a.ada @@ -0,0 +1,297 @@ +-- CC1223A.ADA + +-- Grant of Unlimited Rights +-- +-- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687, +-- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained +-- unlimited rights in the software and documentation contained herein. +-- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making +-- this public release, the Government intends to confer upon all +-- recipients unlimited rights equal to those held by the Government. +-- These rights include rights to use, duplicate, release or disclose the +-- released technical data and computer software in whole or in part, in +-- any manner and for any purpose whatsoever, and to have or permit others +-- to do so. +-- +-- DISCLAIMER +-- +-- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR +-- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED +-- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF 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: +-- FOR A FORMAL FIXED POINT TYPE, CHECK THAT THE FOLLOWING BASIC +-- OPERATIONS ARE IMPLICITLY DECLARED AND ARE THEREFORE AVAILABLE +-- WITHIN THE GENERIC UNIT: ASSIGNMENT, MEMBERSHIP TESTS, +-- QUALIFICATION, EXPLICIT CONVERSION TO AND FROM OTHER NUMERIC +-- TYPES, AND REAL LITERALS (IMPLICIT CONVERSION FROM UNIVERSAL REAL +-- TO THE FORMAL TYPE), 'FIRST, 'LAST, 'SIZE, 'ADDRESS, 'DELTA, 'FORE, +-- 'AFT, 'MACHINE_ROUNDS, 'MACHINE_OVERFLOWS. + +-- HISTORY: +-- RJW 09/30/86 CREATED ORIGINAL TEST. +-- JLH 09/25/87 REFORMATTED HEADER. +-- RJW 08/21/89 MODIFIED CHECKS FOR 'MANTISSA AND 'AFT. +-- PWN 01/31/95 REMOVED INCONSISTENCIES WITH ADA 9X. + +WITH SYSTEM; USE SYSTEM; +WITH REPORT; USE REPORT; + +PROCEDURE CC1223A IS + + TYPE FIXED IS DELTA 0.1 RANGE -100.0 .. 100.0; + +BEGIN + TEST ( "CC1223A", "FOR A FORMAL FIXED POINT TYPE, CHECK " & + "THAT THE BASIC OPERATIONS ARE " & + "IMPLICITLY DECLARED AND ARE THEREFORE " & + "AVAILABLE WITHIN THE GENERIC UNIT" ); + + DECLARE -- (A). CHECKS FOR ASSIGNMENT, MEMBERSHIP TESTS AND + -- QUALIFICATION. + + GENERIC + TYPE T IS DELTA <>; + TYPE T1 IS DELTA <>; + F : T; + F1 : T1; + PROCEDURE P (F2 : T; STR : STRING); + + PROCEDURE P (F2 : T; STR : STRING) IS + SUBTYPE ST IS T RANGE -1.0 .. 1.0; + F3, F4 : T; + + FUNCTION FUN (X : T) RETURN BOOLEAN IS + BEGIN + RETURN IDENT_BOOL (TRUE); + END FUN; + + FUNCTION FUN (X : T1) RETURN BOOLEAN IS + BEGIN + RETURN IDENT_BOOL (FALSE); + END FUN; + + BEGIN + F3 := F; + F4 := F2; + F3 := F4; + + IF F3 /= F2 THEN + FAILED ( "INCORRECT RESULTS FOR ASSIGNMENT " & + "WITH TYPE - " & STR); + END IF; + + IF F IN ST THEN + NULL; + ELSE + FAILED ( "INCORRECT RESULTS FOR ""IN"" WITH " & + "TYPE - " & STR); + END IF; + + IF F2 NOT IN ST THEN + NULL; + ELSE + FAILED ( "INCORRECT RESULTS FOR ""NOT IN"" WITH " & + "TYPE - " & STR); + END IF; + + IF T'(F) /= F THEN + FAILED ( "INCORRECT RESULTS FOR QUALIFICATION " & + "WITH TYPE - " & STR & " - 1" ); + END IF; + + IF FUN (T'(1.0)) THEN + NULL; + ELSE + FAILED ( "INCORRECT RESULTS FOR QUALIFICATION " & + "WITH TYPE - " & STR & " - 2" ); + END IF; + + END P; + + PROCEDURE P1 IS NEW P (FIXED, FIXED, 0.0, 0.0); + PROCEDURE P2 IS NEW P (DURATION, DURATION, 0.0, 0.0); + + BEGIN + P1 (2.0, "FIXED"); + P2 (2.0, "DURATION"); + END; -- (A). + + DECLARE -- (B) CHECKS FOR EXPLICIT CONVERSION TO AND FROM OTHER + -- NUMERIC TYPES, AND IMPLICIT CONVERSION FROM + -- REAL LITERAL. + + GENERIC + TYPE T IS DELTA <>; + PROCEDURE P (STR : STRING); + + PROCEDURE P (STR : STRING) IS + + FL0 : FLOAT := 0.0; + FL2 : FLOAT := 2.0; + FLN2 : FLOAT := -2.0; + + I0 : INTEGER := 0; + I2 : INTEGER := 2; + IN2 : INTEGER := -2; + + T0 : T := 0.0; + T2 : T := 2.0; + TN2 : T := -2.0; + + FUNCTION IDENT (X : T) RETURN T IS + BEGIN + IF EQUAL (3, 3) THEN + RETURN X; + ELSE + RETURN T'FIRST; + END IF; + END IDENT; + + BEGIN + IF T0 + 1.0 /= 1.0 THEN + FAILED ( "INCORRECT RESULTS FOR IMPLICIT " & + "CONVERSION WITH TYPE " & STR & " - 1" ); + END IF; + + IF T2 + 1.0 /= 3.0 THEN + FAILED ( "INCORRECT RESULTS FOR IMPLICIT " & + "CONVERSION WITH TYPE " & STR & " - 2" ); + END IF; + + IF TN2 + 1.0 /= -1.0 THEN + FAILED ( "INCORRECT RESULTS FOR IMPLICIT " & + "CONVERSION WITH TYPE " & STR & " - 3" ); + END IF; + + IF T (FL0) /= T0 THEN + FAILED ( "INCORRECT CONVERSION FROM " & + "FLOAT VALUE 0.0 WITH TYPE " & STR); + END IF; + + IF T (FL2) /= IDENT (T2) THEN + FAILED ( "INCORRECT CONVERSION FROM " & + "FLOAT VALUE 2.0 WITH TYPE " & STR); + END IF; + + IF T (FLN2) /= TN2 THEN + FAILED ( "INCORRECT CONVERSION FROM " & + "FLOAT VALUE -2.0 WITH TYPE " & STR); + END IF; + + IF T (I0) /= IDENT (T0) THEN + FAILED ( "INCORRECT CONVERSION FROM " & + "INTEGER VALUE 0 WITH TYPE " & STR); + END IF; + + IF T (I2) /= T2 THEN + FAILED ( "INCORRECT CONVERSION FROM " & + "INTEGER VALUE 2 WITH TYPE " & STR); + END IF; + + IF T (IN2) /= IDENT (TN2) THEN + FAILED ( "INCORRECT CONVERSION FROM " & + "INTEGER VALUE -2 WITH TYPE " & STR); + END IF; + + IF FLOAT (T0) /= FL0 THEN + FAILED ( "INCORRECT CONVERSION TO " & + "FLOAT VALUE 0.0 WITH TYPE " & STR); + END IF; + + IF FLOAT (IDENT (T2)) /= FL2 THEN + FAILED ( "INCORRECT CONVERSION TO " & + "FLOAT VALUE 2.0 WITH TYPE " & STR); + END IF; + + IF FLOAT (TN2) /= FLN2 THEN + FAILED ( "INCORRECT CONVERSION TO " & + "FLOAT VALUE -2.0 WITH TYPE " & STR); + END IF; + + IF INTEGER (IDENT (T0)) /= I0 THEN + FAILED ( "INCORRECT CONVERSION TO " & + "INTEGER VALUE 0 WITH TYPE " & STR); + END IF; + + IF INTEGER (T2) /= I2 THEN + FAILED ( "INCORRECT CONVERSION TO " & + "INTEGER VALUE 2 WITH TYPE " & STR); + END IF; + + IF INTEGER (IDENT (TN2)) /= IN2 THEN + FAILED ( "INCORRECT CONVERSION TO " & + "INTEGER VALUE -2 WITH TYPE " & STR); + END IF; + + END P; + + PROCEDURE P1 IS NEW P (FIXED); + PROCEDURE P2 IS NEW P (DURATION); + + BEGIN + P1 ( "FIXED" ); + P2 ( "DURATION" ); + END; -- (B). + + DECLARE -- (C) CHECKS FOR ATTRIBUTES. + + GENERIC + TYPE T IS DELTA <>; + F, L, D : T; + PROCEDURE P (STR : STRING); + + PROCEDURE P (STR : STRING) IS + + F1 : T; + A : ADDRESS := F'ADDRESS; + S : INTEGER := F'SIZE; + + I : INTEGER; + + B1 : BOOLEAN := T'MACHINE_ROUNDS; + B2 : BOOLEAN := T'MACHINE_OVERFLOWS; + + BEGIN + IF T'DELTA /= D THEN + FAILED ( "INCORRECT VALUE FOR " & + STR & "'DELTA" ); + END IF; + + IF T'FIRST /= F THEN + FAILED ( "INCORRECT VALUE FOR " & + STR & "'FIRST" ); + END IF; + + IF T'LAST /= L THEN + FAILED ( "INCORRECT VALUE FOR " & + STR & "'LAST" ); + END IF; + + IF T'FORE < 2 THEN + FAILED ( "INCORRECT VALUE FOR " & + STR & "'FORE" ); + END IF; + + IF T'AFT <= 0 THEN + FAILED ( "INCORRECT VALUE FOR " & STR & "'AFT" ); + END IF; + + END P; + + PROCEDURE P1 IS + NEW P (FIXED, FIXED'FIRST, FIXED'LAST, FIXED'DELTA); + PROCEDURE P2 IS + NEW P (DURATION, DURATION'FIRST, DURATION'LAST, + DURATION'DELTA); + + BEGIN + P1 ( "FIXED" ); + P2 ( "DURATION" ); + END; -- (C). + + RESULT; +END CC1223A; diff --git a/gcc/testsuite/ada/acats/tests/cc/cc1224a.ada b/gcc/testsuite/ada/acats/tests/cc/cc1224a.ada new file mode 100644 index 000000000..c419fb7e4 --- /dev/null +++ b/gcc/testsuite/ada/acats/tests/cc/cc1224a.ada @@ -0,0 +1,558 @@ +-- CC1224A.ADA + +-- Grant of Unlimited Rights +-- +-- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687, +-- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained +-- unlimited rights in the software and documentation contained herein. +-- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making +-- this public release, the Government intends to confer upon all +-- recipients unlimited rights equal to those held by the Government. +-- These rights include rights to use, duplicate, release or disclose the +-- released technical data and computer software in whole or in part, in +-- any manner and for any purpose whatsoever, and to have or permit others +-- to do so. +-- +-- DISCLAIMER +-- +-- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR +-- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED +-- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF 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: +-- FOR ARRAY TYPES WITH A NONLIMITED COMPONENT TYPE (OF A FORMAL +-- AND NONFORMAL GENERIC TYPE), CHECK THAT THE FOLLOWING OPERATIONS +-- ARE IMPLICITY DECLARED AND ARE, THEREFORE, AVAILABLE WITHIN THE +-- GENERIC UNIT: ASSIGNMENT, THE OPERATION ASSOCIATED WITH +-- AGGREGATE NOTATION, MEMBERSHIP TESTS, THE OPERATION ASSOCIATED +-- WITH INDEXED COMPONENTS, QUALIFICATION, EXPLICIT CONVERSION, +-- 'SIZE, 'ADDRESS, 'FIRST, 'FIRST (N), 'LAST, 'LAST (N), +-- 'RANGE, 'RANGE (N), 'LENGTH, 'LENGTH (N). + +-- HISTORY: +-- R.WILLIAMS 10/6/86 +-- EDWARD V. BERARD 8/10/90 ADDED CHECKS FOR MULTI-DIMENSIONAL +-- ARRAYS +-- LDC 10/10/90 CHANGED DECLARATIONS OF AD1 - AD6 TO PROCEDURE +-- CALLS OF FA1 - FA6 TO ADDRESS_CHECK AS SUGGESTED +-- BY THE CRG. +-- PWN 01/31/95 REMOVED INCONSISTENCIES WITH ADA 9X. + +WITH SYSTEM ; +WITH REPORT ; + +PROCEDURE CC1224A IS + + SHORT_START : CONSTANT := -10 ; + SHORT_END : CONSTANT := 10 ; + + TYPE SHORT_RANGE IS RANGE SHORT_START .. SHORT_END ; + SHORT_LENGTH : CONSTANT NATURAL := (SHORT_END - SHORT_START + 1) ; + + MEDIUM_START : CONSTANT := 1 ; + MEDIUM_END : CONSTANT := 15 ; + + TYPE MEDIUM_RANGE IS RANGE MEDIUM_START .. MEDIUM_END ; + MEDIUM_LENGTH : CONSTANT NATURAL := + (MEDIUM_END - MEDIUM_START + 1) ; + + TYPE MONTH_TYPE IS (JAN, FEB, MAR, APR, MAY, JUN, JUL, AUG, + SEP, OCT, NOV, DEC) ; + TYPE DAY_TYPE IS RANGE 1 .. 31 ; + TYPE YEAR_TYPE IS RANGE 1904 .. 2050 ; + TYPE DATE IS RECORD + MONTH : MONTH_TYPE ; + DAY : DAY_TYPE ; + YEAR : YEAR_TYPE ; + END RECORD ; + + TODAY : DATE := (AUG, 10, 1990) ; + + TYPE FIRST_TEMPLATE IS ARRAY (SHORT_RANGE RANGE <>, + MEDIUM_RANGE RANGE <>) OF DATE ; + + TYPE SECOND_TEMPLATE IS ARRAY (SHORT_RANGE, MEDIUM_RANGE) + OF DATE ; + + FIRST_ARRAY : FIRST_TEMPLATE (-10 .. 10, 6 .. 10) ; + SECOND_ARRAY : FIRST_TEMPLATE (0 .. 7, 1 .. 15) ; + THIRD_ARRAY : SECOND_TEMPLATE ; + FOURTH_ARRAY : SECOND_TEMPLATE ; + + SUBTYPE SUBINT IS INTEGER RANGE REPORT.IDENT_INT (1) .. + REPORT.IDENT_INT (6); + + TYPE ARRA IS ARRAY (SUBINT) OF SUBINT; + A1 : ARRA := (REPORT.IDENT_INT (1) .. REPORT.IDENT_INT (6) => 1); + A2 : ARRA := (A1'RANGE => 2); + + TYPE ARRB IS ARRAY (SUBINT RANGE <>) OF DATE ; + A3 : ARRB (1 .. 6) := + (REPORT.IDENT_INT (1) .. REPORT.IDENT_INT (6) => TODAY); + + TYPE ARRC IS ARRAY (SUBINT RANGE <>, SUBINT RANGE <>) OF SUBINT; + A4 : CONSTANT ARRC := (1 .. 6 => (1 .. 6 => 4)); + + TYPE ARRD IS ARRAY (SUBINT, SUBINT) OF SUBINT; + A5 : ARRD := (A4'RANGE (1) => (A4'RANGE (2) => 5)); + + TYPE ARRE IS ARRAY (SUBINT) OF DATE ; + A6 : ARRE := (A1'RANGE => TODAY); + + FUNCTION "=" (LEFT : IN SYSTEM.ADDRESS ; + RIGHT : IN SYSTEM.ADDRESS ) RETURN BOOLEAN + RENAMES SYSTEM."=" ; + + GENERIC + + TYPE T1 IS (<>); + TYPE T2 IS PRIVATE; + X2 : T2; + + TYPE FARR1 IS ARRAY (SUBINT) OF T1; + FA1 : FARR1; + + TYPE FARR2 IS ARRAY (SUBINT) OF SUBINT; + FA2 : FARR2; + + TYPE FARR3 IS ARRAY (SUBINT RANGE <>) OF T2; + FA3 : FARR3; + + TYPE FARR4 IS ARRAY (SUBINT RANGE <>, SUBINT RANGE <>) OF T1; + FA4 : FARR4; + + TYPE FARR5 IS ARRAY (SUBINT, SUBINT) OF SUBINT; + FA5 : FARR5; + + TYPE FARR6 IS ARRAY (T1) OF T2; + FA6 : FARR6; + + TYPE FARR7 IS ARRAY (T1) OF T2; + FA7 : FARR7; + + PROCEDURE P ; + + GENERIC + + TYPE FIRST_INDEX IS (<>) ; + TYPE SECOND_INDEX IS (<>) ; + TYPE UNCONSTRAINED_ARRAY IS ARRAY + (FIRST_INDEX RANGE <>, SECOND_INDEX RANGE <>) OF DATE ; + + PROCEDURE TEST_PROCEDURE (FIRST : IN UNCONSTRAINED_ARRAY ; + FFIFS : IN FIRST_INDEX ; + FFILS : IN FIRST_INDEX ; + FSIFS : IN SECOND_INDEX ; + FSILS : IN SECOND_INDEX ; + FFLEN : IN NATURAL ; + FSLEN : IN NATURAL ; + FFIRT : IN FIRST_INDEX ; + FSIRT : IN SECOND_INDEX ; + SECOND : IN UNCONSTRAINED_ARRAY ; + SFIFS : IN FIRST_INDEX ; + SFILS : IN FIRST_INDEX ; + SSIFS : IN SECOND_INDEX ; + SSILS : IN SECOND_INDEX ; + SFLEN : IN NATURAL ; + SSLEN : IN NATURAL ; + SFIRT : IN FIRST_INDEX ; + SSIRT : IN SECOND_INDEX ; + REMARKS : IN STRING) ; + GENERIC + + TYPE FIRST_INDEX IS (<>) ; + TYPE SECOND_INDEX IS (<>) ; + TYPE COMPONENT_TYPE IS PRIVATE ; + TYPE CONSTRAINED_ARRAY IS ARRAY + (FIRST_INDEX,SECOND_INDEX) OF COMPONENT_TYPE ; + + PROCEDURE CTEST_PROCEDURE (FIRST : IN CONSTRAINED_ARRAY ; + FFIRT : IN FIRST_INDEX ; + FSIRT : IN SECOND_INDEX ; + SECOND : IN CONSTRAINED_ARRAY ; + SFIRT : IN FIRST_INDEX ; + SSIRT : IN SECOND_INDEX ; + REMARKS : IN STRING) ; + + + PROCEDURE P IS + + IN1 : INTEGER := FA1'SIZE; + IN2 : INTEGER := FA2'SIZE; + IN3 : INTEGER := FA3'SIZE; + IN4 : INTEGER := FA4'SIZE; + IN5 : INTEGER := FA5'SIZE; + IN6 : INTEGER := FA6'SIZE; + + B1 : FARR1; + + B2 : FARR2; + + SUBTYPE SARR3 IS FARR3 (FA3'RANGE); + B3 : SARR3; + + SUBTYPE SARR4 IS FARR4 (FA4'RANGE (1), FA4'RANGE (2)); + B4 : SARR4; + + B5 : FARR5; + + B6 : FARR6 ; + + PROCEDURE ADDRESS_CHECK(ADDRESS : SYSTEM.ADDRESS) IS + + BEGIN + IF REPORT.EQUAL(1, REPORT.IDENT_INT(2)) THEN + REPORT.COMMENT("DON'T OPTIMIZE OUT ADDRESS_CHECK"); + END IF; + END ADDRESS_CHECK; + + BEGIN -- P + + ADDRESS_CHECK(FA1'ADDRESS); + ADDRESS_CHECK(FA2'ADDRESS); + ADDRESS_CHECK(FA3'ADDRESS); + ADDRESS_CHECK(FA4'ADDRESS); + ADDRESS_CHECK(FA5'ADDRESS); + ADDRESS_CHECK(FA6'ADDRESS); + + B1 := FA1; + + IF B1 /= FARR1 (FA1) THEN + REPORT.FAILED ("INCORRECT RESULTS - 1" ); + END IF; + + B2 := FA2; + + IF B2 /= FARR2 (A2) THEN + REPORT.FAILED ("INCORRECT RESULTS - 2" ); + END IF; + + B3 := FA3; + + IF B3 /= FARR3 (FA3) THEN + REPORT.FAILED ("INCORRECT RESULTS - 3" ); + END IF; + + B4 := FA4; + + IF B4 /= FARR4 (FA4) THEN + REPORT.FAILED ("INCORRECT RESULTS - 4" ); + END IF; + + B5 := FA5; + + IF B5 /= FARR5 (A5) THEN + REPORT.FAILED ("INCORRECT RESULTS - 5" ); + END IF; + + B6 := FA6; + + IF B6 /= FARR6 (FA6) THEN + REPORT.FAILED ("INCORRECT RESULTS - 6" ); + END IF; + + IF FA7 /= FARR7 (FA6) THEN + REPORT.FAILED ("INCORRECT RESULTS - 7" ); + END IF; + + B1 := FARR1'(FA1'RANGE => T1'VAL (1)); + + IF B1 (1) /= FA1 (1) THEN + REPORT.FAILED ("INCORRECT RESULTS - 8" ); + END IF; + + B1 := FARR1'(1 => T1'VAL (1), 2 => T1'VAL (1), + 3 .. 6 => T1'VAL (2)); + + IF B1 (1) /= FA1 (1) THEN + REPORT.FAILED ("INCORRECT RESULTS - 9" ); + END IF; + + B2 := FARR2'(FA2'RANGE => 2); + + IF B2 (2) /= FA2 (2) THEN + REPORT.FAILED ("INCORRECT RESULTS - 10" ); + END IF; + + B3 := FARR3'(1|2|3 => X2, 4|5|6 => X2); + + IF B3 (3) /= FA3 (3) THEN + REPORT.FAILED ("INCORRECT RESULTS - 11" ); + END IF; + + B4 := FARR4'(FA5'RANGE (1) => (FA5'RANGE (2) => T1'VAL (4))); + + IF B4 (4, 4) /= FA4 (4, 4) THEN + REPORT.FAILED ("INCORRECT RESULTS - 12" ); + END IF; + + B5 := FARR5'(REPORT.IDENT_INT (1) .. + REPORT.IDENT_INT (6) => (1 .. 6 => 5)); + + IF B5 (5, 5) /= FA5 (5, 5) THEN + REPORT.FAILED ("INCORRECT RESULTS - 13" ); + END IF; + + B6 := FARR6'(FA6'RANGE => X2); + + IF B6 (T1'FIRST) /= FA6 (T1'FIRST) THEN + REPORT.FAILED ("INCORRECT RESULTS - 14" ); + END IF; + + IF B1 NOT IN FARR1 THEN + REPORT.FAILED ("INCORRECT RESULTS - 15" ); + END IF; + + IF FA2 NOT IN FARR2 THEN + REPORT.FAILED ("INCORRECT RESULTS - 16" ); + END IF; + + IF FA3 NOT IN FARR3 THEN + REPORT.FAILED ("INCORRECT RESULTS - 17" ); + END IF; + + IF B4 NOT IN FARR4 THEN + REPORT.FAILED ("INCORRECT RESULTS - 18" ); + END IF; + + IF B5 NOT IN FARR5 THEN + REPORT.FAILED ("INCORRECT RESULTS - 19" ); + END IF; + + IF FA6 NOT IN FARR6 THEN + REPORT.FAILED ("INCORRECT RESULTS - 20" ); + END IF; + + IF FA1'LENGTH /= FA1'LAST - FA1'FIRST + 1 THEN + REPORT.FAILED ("INCORRECT RESULTS - 27" ); + END IF; + + IF FA2'LENGTH /= FA2'LAST - FA2'FIRST + 1 THEN + REPORT.FAILED ("INCORRECT RESULTS - 28" ); + END IF; + + IF FA3'LENGTH /= FA3'LAST - FA3'FIRST + 1 THEN + REPORT.FAILED ("INCORRECT RESULTS - 29" ); + END IF; + + IF FA4'LENGTH /= FA4'LAST - FA4'FIRST + 1 THEN + REPORT.FAILED ("INCORRECT RESULTS - 30" ); + END IF; + + IF FA4'LENGTH (2) /= FA4'LAST (2) - FA4'FIRST (2) + 1 THEN + REPORT.FAILED ("INCORRECT RESULTS - 31" ); + END IF; + + IF FA5'LENGTH /= FA5'LAST - FA5'FIRST + 1 THEN + REPORT.FAILED ("INCORRECT RESULTS - 32" ); + END IF; + + IF FA5'LENGTH (2) /= FA5'LAST (2) - FA5'FIRST (2) + 1 THEN + REPORT.FAILED ("INCORRECT RESULTS - 33" ); + END IF; + + IF FA6'LENGTH /= T1'POS (FA6'LAST) - + T1'POS (FA6'FIRST) + 1 THEN + REPORT.FAILED ("INCORRECT RESULTS - 34" ); + END IF; + + END P ; + + PROCEDURE TEST_PROCEDURE (FIRST : IN UNCONSTRAINED_ARRAY ; + FFIFS : IN FIRST_INDEX ; + FFILS : IN FIRST_INDEX ; + FSIFS : IN SECOND_INDEX ; + FSILS : IN SECOND_INDEX ; + FFLEN : IN NATURAL ; + FSLEN : IN NATURAL ; + FFIRT : IN FIRST_INDEX ; + FSIRT : IN SECOND_INDEX ; + SECOND : IN UNCONSTRAINED_ARRAY ; + SFIFS : IN FIRST_INDEX ; + SFILS : IN FIRST_INDEX ; + SSIFS : IN SECOND_INDEX ; + SSILS : IN SECOND_INDEX ; + SFLEN : IN NATURAL ; + SSLEN : IN NATURAL ; + SFIRT : IN FIRST_INDEX ; + SSIRT : IN SECOND_INDEX ; + REMARKS : IN STRING) IS + + BEGIN -- TEST_PROCEDURE + + IF (FIRST'FIRST /= FFIFS) OR + (FIRST'FIRST (1) /= FFIFS) OR + (FIRST'FIRST (2) /= FSIFS) OR + (SECOND'FIRST /= SFIFS) OR + (SECOND'FIRST (1) /= SFIFS) OR + (SECOND'FIRST (2) /= SSIFS) THEN + REPORT.FAILED ("PROBLEMS WITH 'FIRST. " & REMARKS) ; + END IF ; + + IF (FIRST'LAST /= FFILS) OR + (FIRST'LAST (1) /= FFILS) OR + (FIRST'LAST (2) /= FSILS) OR + (SECOND'LAST /= SFILS) OR + (SECOND'LAST (1) /= SFILS) OR + (SECOND'LAST (2) /= SSILS) THEN + REPORT.FAILED ("PROBLEMS WITH 'LAST. " & REMARKS) ; + END IF ; + + IF (FIRST'LENGTH /= FFLEN) OR + (FIRST'LENGTH (1) /= FFLEN) OR + (FIRST'LENGTH (2) /= FSLEN) OR + (SECOND'LENGTH /= SFLEN) OR + (SECOND'LENGTH (1) /= SFLEN) OR + (SECOND'LENGTH (2) /= SSLEN) THEN + REPORT.FAILED ("PROBLEMS WITH 'LENGTH. " & REMARKS) ; + END IF ; + + IF (FFIRT NOT IN FIRST'RANGE (1)) OR + (FFIRT NOT IN FIRST'RANGE) OR + (SFIRT NOT IN SECOND'RANGE (1)) OR + (SFIRT NOT IN SECOND'RANGE) OR + (FSIRT NOT IN FIRST'RANGE (2)) OR + (SSIRT NOT IN SECOND'RANGE (2)) THEN + REPORT.FAILED ("INCORRECT HANDLING OF 'RANGE ATTRIBUE. " & + REMARKS) ; + END IF ; + + END TEST_PROCEDURE ; + + PROCEDURE CTEST_PROCEDURE (FIRST : IN CONSTRAINED_ARRAY ; + FFIRT : IN FIRST_INDEX ; + FSIRT : IN SECOND_INDEX ; + SECOND : IN CONSTRAINED_ARRAY ; + SFIRT : IN FIRST_INDEX ; + SSIRT : IN SECOND_INDEX ; + REMARKS : IN STRING) IS + + BEGIN -- CTEST_PROCEDURE + + IF (FIRST'FIRST /= FIRST_INDEX'FIRST) OR + (FIRST'FIRST (1) /= FIRST_INDEX'FIRST) OR + (FIRST'FIRST (2) /= SECOND_INDEX'FIRST) OR + (SECOND'FIRST /= FIRST_INDEX'FIRST) OR + (SECOND'FIRST (1) /= FIRST_INDEX'FIRST) OR + (SECOND'FIRST (2) /= SECOND_INDEX'FIRST) THEN + REPORT.FAILED ("PROBLEMS WITH 'FIRST. " & REMARKS) ; + END IF ; + + IF (FIRST'LAST /= FIRST_INDEX'LAST) OR + (FIRST'LAST (1) /= FIRST_INDEX'LAST) OR + (FIRST'LAST (2) /= SECOND_INDEX'LAST) OR + (SECOND'LAST /= FIRST_INDEX'LAST) OR + (SECOND'LAST (1) /= FIRST_INDEX'LAST) OR + (SECOND'LAST (2) /= SECOND_INDEX'LAST) THEN + REPORT.FAILED ("PROBLEMS WITH 'LAST. " & REMARKS) ; + END IF ; + + IF (FIRST'LENGTH /= + FIRST_INDEX'POS (FIRST_INDEX'LAST) + - FIRST_INDEX'POS (FIRST_INDEX'FIRST) + 1) OR + (FIRST'LENGTH (1) /= + FIRST_INDEX'POS (FIRST_INDEX'LAST) + - FIRST_INDEX'POS (FIRST_INDEX'FIRST) + 1) OR + (FIRST'LENGTH (2) /= + SECOND_INDEX'POS (SECOND_INDEX'LAST) + - SECOND_INDEX'POS (SECOND_INDEX'FIRST) + 1) OR + (SECOND'LENGTH /= + FIRST_INDEX'POS (FIRST_INDEX'LAST) + - FIRST_INDEX'POS (FIRST_INDEX'FIRST) + 1) OR + (SECOND'LENGTH (1) /= + FIRST_INDEX'POS (FIRST_INDEX'LAST) + - FIRST_INDEX'POS (FIRST_INDEX'FIRST) + 1) OR + (SECOND'LENGTH (2) /= + SECOND_INDEX'POS (SECOND_INDEX'LAST) + - SECOND_INDEX'POS (SECOND_INDEX'FIRST) + 1) THEN + REPORT.FAILED ("PROBLEMS WITH 'LENGTH. " & REMARKS) ; + END IF ; + + IF (FFIRT NOT IN FIRST'RANGE (1)) OR + (FFIRT NOT IN FIRST'RANGE) OR + (SFIRT NOT IN SECOND'RANGE (1)) OR + (SFIRT NOT IN SECOND'RANGE) OR + (FSIRT NOT IN FIRST'RANGE (2)) OR + (SSIRT NOT IN SECOND'RANGE (2)) THEN + REPORT.FAILED ("INCORRECT HANDLING OF 'RANGE ATTRIBUE. " & + REMARKS) ; + END IF ; + + IF CONSTRAINED_ARRAY'SIZE <= 0 THEN + REPORT.FAILED ("PROBLEMS WITH THE 'SIZE ATTRIBUTE. " & + REMARKS) ; + END IF ; + + IF FIRST'ADDRESS = SECOND'ADDRESS THEN + REPORT.FAILED ("PROBLEMS WITH THE 'ADDRESS ATTRIBUTE. " & + REMARKS) ; + END IF ; + + END CTEST_PROCEDURE ; + + PROCEDURE FIRST_TEST_PROCEDURE IS NEW TEST_PROCEDURE + (FIRST_INDEX => SHORT_RANGE, + SECOND_INDEX => MEDIUM_RANGE, + UNCONSTRAINED_ARRAY => FIRST_TEMPLATE) ; + + PROCEDURE NEW_CTEST_PROCEDURE IS NEW CTEST_PROCEDURE + (FIRST_INDEX => SHORT_RANGE, + SECOND_INDEX => MEDIUM_RANGE, + COMPONENT_TYPE => DATE, + CONSTRAINED_ARRAY => SECOND_TEMPLATE) ; + + PROCEDURE NP IS NEW P (SUBINT, DATE, TODAY, ARRA, A1, + ARRA, A2, ARRB, A3, ARRC, A4, ARRD, + A5, ARRE, A6, ARRE, A6); + +BEGIN -- CC1224A + + REPORT.TEST ("CC1224A", "FOR ARRAY TYPES WITH A NONLIMITED " & + "COMPONENT TYPE (OF A FORMAL AND NONFORMAL GENERIC " & + "TYPE), CHECK THAT THE FOLLOWING OPERATIONS " & + "ARE IMPLICITY DECLARED AND ARE, THEREFORE, " & + "AVAILABLE WITHIN THE GENERIC -- UNIT: " & + "ASSIGNMENT, THE OPERATION ASSOCIATED WITH " & + "AGGREGATE NOTATION, MEMBERSHIP TESTS, THE " & + "OPERATION ASSOCIATED WITH INDEXED " & + "COMPONENTS, QUALIFICATION, EXPLICIT " & + "CONVERSION, 'SIZE, 'ADDRESS, 'FIRST, " & + "'FIRST (N), 'LAST, 'LAST (N), 'RANGE, " & + "'RANGE (N), 'LENGTH, 'LENGTH (N)" ) ; + + NP ; + + FIRST_TEST_PROCEDURE (FIRST => FIRST_ARRAY, + FFIFS => -10, + FFILS => 10, + FSIFS => 6, + FSILS => 10, + FFLEN => 21, + FSLEN => 5, + FFIRT => 0, + FSIRT => 8, + SECOND => SECOND_ARRAY, + SFIFS => 0, + SFILS => 7, + SSIFS => 1, + SSILS => 15, + SFLEN => 8, + SSLEN => 15, + SFIRT => 5, + SSIRT => 13, + REMARKS => "FIRST_TEST_PROCEDURE") ; + + NEW_CTEST_PROCEDURE (FIRST => THIRD_ARRAY, + FFIRT => -5, + FSIRT => 11, + SECOND => FOURTH_ARRAY, + SFIRT => 0, + SSIRT => 14, + REMARKS => "NEW_CTEST_PROCEDURE") ; + + REPORT.RESULT ; + +END CC1224A; diff --git a/gcc/testsuite/ada/acats/tests/cc/cc1225a.tst b/gcc/testsuite/ada/acats/tests/cc/cc1225a.tst new file mode 100644 index 000000000..dfad3b0ed --- /dev/null +++ b/gcc/testsuite/ada/acats/tests/cc/cc1225a.tst @@ -0,0 +1,350 @@ +-- CC1225A.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, FOR A FORMAL ACCESS TYPE, THAT ALL ALLOWABLE OPERATIONS +-- ARE IMPLICITLY DECLARED. + +-- MACRO SUBSTITUTION: +-- $TASK_STORAGE_SIZE IS THE NUMBER OF STORAGE_UNITS REQUIRED FOR +-- THE ACTIVATION OF A TASK. + +-- HISTORY: +-- BCB 03/29/88 CREATED ORIGINAL TEST. +-- RDH 04/09/90 ADDED 'STORAGE_SIZE CLAUSES. CHANGED EXTENSION TO +-- 'TST'. +-- LDC 09/26/90 REMOVED 'USE PACK' AFTER THE WITH SINCE IT ISN'T +-- NEEDED, ADDED CHECK FOR NULL AFTER ASSIGMENT TO +-- NULL, ADDED CHECKS FOR OTHER RELATION OPERATORS, +-- CHANGED CHECK FOR 'ADDRESS TO A PROCEDURE CALL. +-- LDC 10/13/90 CHANGED CHECK FOR 'SIZE TO ONLY CHECK FOR +-- AVAILABILITY. CHANGED CHECK FOR 'ADDRESS TO A +-- MEMBERSHIP TEST. +-- PWN 01/31/95 REMOVED INCONSISTENCIES WITH ADA 9X. + +WITH REPORT; USE REPORT; +WITH SYSTEM; USE SYSTEM; + +PROCEDURE CC1225A IS + + TASK_STORAGE_SIZE : CONSTANT := $TASK_STORAGE_SIZE; + + TYPE AI IS ACCESS INTEGER; + + TYPE ACCINTEGER IS ACCESS INTEGER; + + TYPE REC IS RECORD + COMP : INTEGER; + END RECORD; + + TYPE DISCREC (DISC : INTEGER := 1) IS RECORD + COMPD : INTEGER; + END RECORD; + + TYPE AREC IS ACCESS REC; + + TYPE ADISCREC IS ACCESS DISCREC; + + TYPE ARR IS ARRAY(1..2,1..2) OF INTEGER; + + TYPE ONEDIM IS ARRAY(1..10) OF INTEGER; + + TYPE AA IS ACCESS ARR; + + TYPE AONEDIM IS ACCESS ONEDIM; + + TYPE ENUM IS (ONE, TWO, THREE); + + TASK TYPE T IS + ENTRY HERE(VAL : IN OUT INTEGER); + END T; + + TYPE ATASK IS ACCESS T; + + TYPE ANOTHERTASK IS ACCESS T; + FOR ANOTHERTASK'STORAGE_SIZE USE 2 * TASK_STORAGE_SIZE; + + TASK TYPE T1 IS + ENTRY HERE1(ENUM)(VAL1 : IN OUT INTEGER); + END T1; + + TYPE ATASK1 IS ACCESS T1; + + TASK BODY T IS + BEGIN + ACCEPT HERE(VAL : IN OUT INTEGER) DO + VAL := VAL * 2; + END HERE; + END T; + + TASK BODY T1 IS + BEGIN + SELECT + ACCEPT HERE1(ONE)(VAL1 : IN OUT INTEGER) DO + VAL1 := VAL1 * 1; + END HERE1; + OR + ACCEPT HERE1(TWO)(VAL1 : IN OUT INTEGER) DO + VAL1 := VAL1 * 2; + END HERE1; + OR + ACCEPT HERE1(THREE)(VAL1 : IN OUT INTEGER) DO + VAL1 := VAL1 * 3; + END HERE1; + END SELECT; + END T1; + + GENERIC + TYPE FORM IS (<>); + TYPE ACCFORM IS ACCESS FORM; + TYPE ACC IS ACCESS INTEGER; + TYPE ACCREC IS ACCESS REC; + TYPE ACCDISCREC IS ACCESS DISCREC; + TYPE ACCARR IS ACCESS ARR; + TYPE ACCONE IS ACCESS ONEDIM; + TYPE ACCTASK IS ACCESS T; + TYPE ACCTASK1 IS ACCESS T1; + TYPE ANOTHERTASK1 IS ACCESS T; + PACKAGE P IS + END P; + + PACKAGE BODY P IS + AF : ACCFORM; + TYPE DER_ACC IS NEW ACC; + A, B : ACC; + DERA : DER_ACC; + R : ACCREC; + DR : ACCDISCREC; + C : ACCARR; + D, E : ACCONE; + F : ACCTASK; + G : ACCTASK1; + INT : INTEGER := 5; + + BEGIN + TEST ("CC1225A", "CHECK, FOR A FORMAL ACCESS TYPE, THAT " & + "ALL ALLOWABLE OPERATIONS ARE IMPLICITLY " & + "DECLARED"); + + IF AF'ADDRESS NOT IN ADDRESS THEN + FAILED ("IMPROPER RESULT FROM AF'ADDRESS TEST"); + END IF; + + DECLARE + AF_SIZE : INTEGER := ACCFORM'SIZE; + BEGIN + IF AF_SIZE NOT IN INTEGER THEN + FAILED ("IMPROPER RESULT FROM AF'SIZE"); + END IF; + END; + + IF ANOTHERTASK1'STORAGE_SIZE < TASK_STORAGE_SIZE THEN + FAILED ("IMPROPER VALUE FOR ANOTHERTASK1'STORAGE_SIZE"); + END IF; + + B := NEW INTEGER'(25); + + A := B; + + IF A.ALL /= 25 THEN + FAILED ("IMPROPER VALUE FOR ASSIGNMENT OF VARIABLE " & + "OF A FORMAL ACCESS TYPE FROM ANOTHER " & + "VARIABLE OF A FORMAL ACCESS TYPE"); + END IF; + + A := NEW INTEGER'(10); + + IF A.ALL /= 10 THEN + FAILED ("IMPROPER VALUE FOR VARIABLE OF FORMAL ACCESS " & + "TYPE"); + END IF; + + IF A NOT IN ACC THEN + FAILED ("IMPROPER RESULT FROM MEMBERSHIP TEST"); + END IF; + + B := ACC'(A); + + IF B.ALL /= 10 THEN + FAILED ("IMPROPER VALUE FROM QUALIFICATION"); + END IF; + + DERA := NEW INTEGER'(10); + A := ACC(DERA); + + IF A.ALL /= IDENT_INT(10) THEN + FAILED ("IMPROPER VALUE FROM EXPLICIT CONVERSION"); + END IF; + + IF A.ALL > IDENT_INT(10) THEN + FAILED ("IMPROPER VALUE USED IN LESS THAN"); + END IF; + + IF A.ALL < IDENT_INT(10) THEN + FAILED ("IMPROPER VALUE USED IN GREATER THAN"); + END IF; + + IF A.ALL >= IDENT_INT(11) THEN + FAILED ("IMPROPER VALUE USED IN LESS THAN OR EQUAL"); + END IF; + + IF A.ALL <= IDENT_INT(9) THEN + FAILED ("IMPROPER VALUE USED IN GREATER THAN OR EQUAL"); + END IF; + + IF NOT (A.ALL + A.ALL = IDENT_INT(20)) THEN + FAILED ("IMPROPER VALUE FROM ADDITION"); + END IF; + + IF NOT (A.ALL - IDENT_INT(2) = IDENT_INT(8)) THEN + FAILED ("IMPROPER VALUE FROM SUBTRACTION"); + END IF; + + IF NOT (A.ALL * IDENT_INT(3) = IDENT_INT(30)) THEN + FAILED ("IMPROPER VALUE FROM MULTIPLICATION"); + END IF; + + IF NOT (A.ALL / IDENT_INT(3) = IDENT_INT(3)) THEN + FAILED ("IMPROPER VALUE FROM DIVISION"); + END IF; + + IF NOT (A.ALL MOD IDENT_INT(3) = IDENT_INT(1)) THEN + FAILED ("IMPROPER VALUE FROM MODULO"); + END IF; + + IF NOT (A.ALL REM IDENT_INT(7) = IDENT_INT(3)) THEN + FAILED ("IMPROPER VALUE FROM REMAINDER"); + END IF; + + IF NOT (A.ALL ** IDENT_INT(2) = IDENT_INT(100)) THEN + FAILED ("IMPROPER VALUE FROM EXPONENTIATION"); + END IF; + + IF NOT (+A.ALL = IDENT_INT(10)) THEN + FAILED ("IMPROPER VALUE FROM IDENTITY"); + END IF; + + IF NOT (-A.ALL = IDENT_INT(-10)) THEN + FAILED ("IMPROPER VALUE FROM NEGATION"); + END IF; + + A := NULL; + + IF A /= NULL THEN + FAILED ("IMPROPER VALUE FROM ACCESS SET TO NULL"); + END IF; + + IF A'ADDRESS NOT IN ADDRESS THEN + FAILED ("IMPROPER RESULT FROM A'ADDRESS TEST"); + END IF; + + + DECLARE + ACC_SIZE : INTEGER := ACC'SIZE; + BEGIN + IF ACC_SIZE NOT IN INTEGER THEN + FAILED ("IMPROPER RESULT FROM ACC'SIZE"); + END IF; + END; + + R := NEW REC'(COMP => 5); + + IF NOT EQUAL(R.COMP,5) THEN + FAILED ("IMPROPER VALUE FOR RECORD COMPONENT"); + END IF; + + DR := NEW DISCREC'(DISC => 1, COMPD => 5); + + IF NOT EQUAL(DR.DISC,1) OR NOT EQUAL(DR.COMPD,5) THEN + FAILED ("IMPROPER VALUES FOR DISCRIMINATED RECORD " & + "COMPONENTS"); + END IF; + + C := NEW ARR'(1 => (1,2), 2 => (3,4)); + + IF C(1,1) /= 1 OR C(1,2) /= 2 OR C(2,1) /= 3 OR C(2,2) /= 4 + THEN FAILED ("IMPROPER ARRAY COMPONENT VALUES"); + END IF; + + D := NEW ONEDIM'(1,2,3,4,5,6,7,8,9,10); + E := NEW ONEDIM'(10,9,8,7,6,5,4,3,2,1); + + D(1..5) := E(1..5); + + IF D(1) /= 10 OR D(2) /= 9 OR D(3) /= 8 + OR D(4) /= 7 OR D(5) /= 6 THEN + FAILED ("IMPROPER RESULTS FROM SLICE ASSIGNMENT"); + END IF; + + IF C'FIRST /= 1 OR C'FIRST(2) /= 1 THEN + FAILED ("IMPROPER LOWER BOUNDS FOR CONSTRAINED ARRAY"); + END IF; + + IF C'LAST /= 2 OR C'LAST(2) /= 2 THEN + FAILED ("IMPROPER UPPER BOUNDS FOR CONSTRAINED ARRAY"); + END IF; + + IF 1 NOT IN C'RANGE THEN + FAILED ("IMPROPER RANGE FOR CONSTRAINED ARRAY - 1"); + END IF; + + IF 1 NOT IN C'RANGE(2) THEN + FAILED ("IMPROPER RANGE FOR CONSTRAINED ARRAY - 2"); + END IF; + + IF C'LENGTH /= 2 THEN + FAILED ("IMPROPER NUMBER OF VALUES FOR CONSTRAINED " & + "ARRAY - 1"); + END IF; + + IF C'LENGTH(2) /= 2 THEN + FAILED ("IMPROPER NUMBER OF VALUES FOR CONSTRAINED " & + "ARRAY - 2"); + END IF; + + F := NEW T; + + F.HERE(INT); + + IF NOT EQUAL(INT,IDENT_INT(10)) THEN + FAILED ("IMPROPER RESULTS FROM ENTRY SELECTION"); + END IF; + + G := NEW T1; + + G.HERE1(TWO)(INT); + + IF NOT EQUAL(INT,IDENT_INT(20)) THEN + FAILED ("IMPROPER RESULTS FROM FAMILY ENTRY SELECTION"); + END IF; + + RESULT; + END P; + + PACKAGE PACK IS NEW P(INTEGER,ACCINTEGER,AI,AREC,ADISCREC, + AA,AONEDIM,ATASK,ATASK1,ANOTHERTASK); + +BEGIN + NULL; +END CC1225A; diff --git a/gcc/testsuite/ada/acats/tests/cc/cc1226b.ada b/gcc/testsuite/ada/acats/tests/cc/cc1226b.ada new file mode 100644 index 000000000..c127dc15b --- /dev/null +++ b/gcc/testsuite/ada/acats/tests/cc/cc1226b.ada @@ -0,0 +1,176 @@ +-- CC1226B.ADA + +-- Grant of Unlimited Rights +-- +-- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687, +-- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained +-- unlimited rights in the software and documentation contained herein. +-- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making +-- this public release, the Government intends to confer upon all +-- recipients unlimited rights equal to those held by the Government. +-- These rights include rights to use, duplicate, release or disclose the +-- released technical data and computer software in whole or in part, in +-- any manner and for any purpose whatsoever, and to have or permit others +-- to do so. +-- +-- DISCLAIMER +-- +-- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR +-- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED +-- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF 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, FOR A FORMAL NONLIMITED PRIVATE TYPE, THAT ALL ALLOWABLE +-- OPERATIONS ARE IMPLICITLY DECLARED. + +-- HISTORY: +-- BCB 04/04/88 CREATED ORIGINAL TEST. +-- RJW 03/28/90 INITIALIZED PREVIOUSLY UNINITIALIZED VARIABLES. +-- LDC 09/19/90 INITALIZED NLPVAR & NLPVAR2 TO DIFFERENT VALUES, +-- REMOVED USE CLAUSE. +-- PWN 01/31/95 REMOVED INCONSISTENCIES WITH ADA 9X. + +WITH REPORT; USE REPORT; +WITH SYSTEM; USE SYSTEM; + +PROCEDURE CC1226B IS + + TYPE DISCREC(DISC1 : INTEGER := 1; + DISC2 : BOOLEAN := FALSE) IS RECORD + NULL; + END RECORD; + + GENERIC + TYPE NLP IS PRIVATE; + TYPE NLPDISC(DISC1 : INTEGER; + DISC2 : BOOLEAN) IS PRIVATE; + WITH PROCEDURE INITIALIZE (N : OUT NLPDISC); + WITH FUNCTION INITIALIZE RETURN NLP; + WITH FUNCTION INITIALIZE_2 RETURN NLP; + PACKAGE P IS + FUNCTION IDENT(X : NLP) RETURN NLP; + FUNCTION IDENT_ADR(Y : ADDRESS) RETURN ADDRESS; + END P; + + PACKAGE BODY P IS + TYPE DER_NLP IS NEW NLP; + NLPVAR : NLP := INITIALIZE_2; + NLPVAR2, NLPVAR3 : NLP := INITIALIZE; + DERNLP : DER_NLP := DER_NLP (INITIALIZE); + NDVAR : NLPDISC(DISC1 => 5, DISC2 => TRUE); + NLPVARADDRESS : ADDRESS; + NLPSIZE : INTEGER; + NLPBASESIZE : INTEGER; + + FUNCTION IDENT(X : NLP) RETURN NLP IS + Z : NLP := INITIALIZE; + BEGIN + IF EQUAL(3,3) THEN + RETURN X; + END IF; + RETURN Z; + END IDENT; + + FUNCTION IDENT_ADR(Y : ADDRESS) RETURN ADDRESS IS + I : INTEGER; + Z : ADDRESS := I'ADDRESS; + BEGIN + IF EQUAL(3,3) THEN + RETURN Y; + END IF; + RETURN Z; + END IDENT_ADR; + + BEGIN + TEST ("CC1226B", "CHECK, FOR A FORMAL NONLIMITED PRIVATE " & + "TYPE THAT ALL ALLOWABLE OPERATIONS ARE " & + "IMPLICITLY DECLARED"); + + INITIALIZE (NDVAR); + + NLPVAR := NLPVAR2; + + IF NLPVAR /= NLPVAR2 THEN + FAILED ("IMPROPER VALUE FROM ASSIGNMENT"); + END IF; + + IF NLPVAR NOT IN NLP THEN + FAILED ("IMPROPER RESULT FROM MEMBERSHIP TEST"); + END IF; + + NLPVAR := NLP'(NLPVAR2); + + IF NLPVAR /= NLPVAR2 THEN + FAILED ("IMPROPER RESULT FROM QUALIFICATION"); + END IF; + + NLPVAR := NLP(DERNLP); + + IF NLPVAR /= IDENT(NLP(DERNLP)) THEN + FAILED ("IMPROPER RESULT FROM EXPLICIT CONVERSION"); + END IF; + + NLPSIZE := IDENT_INT(NLP'SIZE); + + IF NLPSIZE /= INTEGER(NLP'SIZE) THEN + FAILED ("IMPROPER VALUE FOR NLP'SIZE"); + END IF; + + NLPVARADDRESS := NLPVAR'ADDRESS; + + IF NLPVAR'ADDRESS /= IDENT_ADR(NLPVARADDRESS) THEN + FAILED ("IMPROPER VALUE FOR NLPVAR'ADDRESS"); + END IF; + + IF NDVAR.DISC1 /= IDENT_INT(5) THEN + FAILED ("IMPROPER DISCRIMINANT VALUE - 1"); + END IF; + + IF NOT NDVAR.DISC2 THEN + FAILED ("IMPROPER DISCRIMINANT VALUE - 2"); + END IF; + + IF NOT NDVAR'CONSTRAINED THEN + FAILED ("IMPROPER VALUE FOR NDVAR'CONSTRAINED"); + END IF; + + NLPVAR := NLPVAR3; + + IF NOT (NLPVAR = IDENT(NLPVAR3)) THEN + FAILED ("IMPROPER VALUE FROM EQUALITY OPERATION"); + END IF; + + IF NLPVAR /= IDENT(NLPVAR3) THEN + FAILED ("IMPROPER VALUE FROM INEQUALITY OPERATION"); + END IF; + + RESULT; + END P; + + PROCEDURE INITIALIZE (I : OUT DISCREC) IS + BEGIN + I := (5, TRUE); + END INITIALIZE; + + FUNCTION INITIALIZE RETURN INTEGER IS + BEGIN + RETURN 5; + END INITIALIZE; + + FUNCTION INITIALIZE_OTHER RETURN INTEGER IS + BEGIN + RETURN 3; + END INITIALIZE_OTHER; + + PACKAGE PACK IS NEW P(INTEGER, + DISCREC, + INITIALIZE, + INITIALIZE, + INITIALIZE_OTHER); + +BEGIN + NULL; +END CC1226B; diff --git a/gcc/testsuite/ada/acats/tests/cc/cc1227a.ada b/gcc/testsuite/ada/acats/tests/cc/cc1227a.ada new file mode 100644 index 000000000..39b453287 --- /dev/null +++ b/gcc/testsuite/ada/acats/tests/cc/cc1227a.ada @@ -0,0 +1,289 @@ +-- CC1227A.ADA + +-- Grant of Unlimited Rights +-- +-- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687, +-- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained +-- unlimited rights in the software and documentation contained herein. +-- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making +-- this public release, the Government intends to confer upon all +-- recipients unlimited rights equal to those held by the Government. +-- These rights include rights to use, duplicate, release or disclose the +-- released technical data and computer software in whole or in part, in +-- any manner and for any purpose whatsoever, and to have or permit others +-- to do so. +-- +-- DISCLAIMER +-- +-- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR +-- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED +-- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF 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, WHEN DERIVING FROM A FORMAL TYPE, THAT ALL THE PREDEFINED +-- OPERATIONS ASSOCIATED WITH THE CLASS OF THE FORMAL TYPE ARE +-- DECLARED FOR THE DERIVED TYPE. + +-- HISTORY: +-- BCB 04/04/88 CREATED ORIGINAL TEST. + +WITH REPORT; USE REPORT; +WITH SYSTEM; USE SYSTEM; + +PROCEDURE CC1227A IS + + GENERIC + TYPE FORM IS RANGE <>; + PACKAGE P IS + TYPE DER_FORM IS NEW FORM; + FUNCTION IDENT_DER(X : DER_FORM) RETURN DER_FORM; + FUNCTION IDENT_ADR(Y : ADDRESS) RETURN ADDRESS; + END P; + + PACKAGE BODY P IS + DER_VAR : DER_FORM; + DER_FORM_BASE_FIRST : DER_FORM; + DER_FORM_FIRST : DER_FORM; + DER_FORM_LAST : DER_FORM; + DER_FORM_SIZE : DER_FORM; + DER_FORM_WIDTH : DER_FORM; + DER_FORM_POS : DER_FORM; + DER_FORM_VAL : DER_FORM; + DER_FORM_SUCC : DER_FORM; + DER_FORM_PRED : DER_FORM; + DER_FORM_IMAGE : STRING(1..5); + DER_FORM_VALUE : DER_FORM; + DER_VAR_SIZE : DER_FORM; + DER_VAR_ADDRESS : ADDRESS; + DER_EQUAL, DER_UNEQUAL : DER_FORM; + DER_GREATER : DER_FORM; + DER_MOD, DER_REM : DER_FORM; + DER_ABS, DER_EXP : DER_FORM; + INT : INTEGER := 5; + FUNCTION IDENT_DER(X : DER_FORM) RETURN DER_FORM IS + BEGIN + IF EQUAL(3,3) THEN + RETURN X; + END IF; + RETURN 0; + END IDENT_DER; + FUNCTION IDENT_ADR(Y : ADDRESS) RETURN ADDRESS IS + X : DER_FORM; + BEGIN + IF EQUAL(3,3) THEN + RETURN Y; + END IF; + RETURN X'ADDRESS; + END IDENT_ADR; + BEGIN + TEST ("CC1227A", "CHECK, WHEN DERIVING FROM A FORMAL TYPE, " & + "THAT ALL THE PREDEFINED OPERATIONS " & + "ASSOCIATED WITH THE CLASS OF THE FORMAL " & + "TYPE ARE DECLARED FOR THE DERIVED TYPE"); + + DER_VAR := IDENT_DER(1); + + IF DER_VAR /= 1 THEN + FAILED ("IMPROPER VALUE FROM ASSIGNMENT OPERATION"); + END IF; + + IF DER_VAR NOT IN DER_FORM THEN + FAILED ("IMPROPER RESULT FROM MEMBERSHIP TEST"); + END IF; + + DER_VAR := DER_FORM'(2); + + IF DER_VAR /= IDENT_DER(2) THEN + FAILED ("IMPROPER RESULT FROM QUALIFICATION"); + END IF; + + DER_VAR := DER_FORM(INT); + + IF DER_VAR /= IDENT_DER(5) THEN + FAILED ("IMPROPER RESULT FROM EXPLICIT CONVERSION - " & + "INTEGER"); + END IF; + + DER_VAR := DER_FORM(3.0); + + IF DER_VAR /= IDENT_DER(3) THEN + FAILED ("IMPROPER RESULT FROM EXPLICIT CONVERSION - " & + "FLOAT"); + END IF; + + DER_VAR := 1_000; + + IF DER_VAR /= IDENT_DER(1000) THEN + FAILED ("IMPROPER RESULT FROM IMPLICIT CONVERSION"); + END IF; + + DER_FORM_BASE_FIRST := DER_FORM'BASE'FIRST; + + DER_FORM_FIRST := DER_FORM'FIRST; + + IF DER_FORM_BASE_FIRST /= IDENT_DER(DER_FORM_FIRST) THEN + FAILED ("IMPROPER VALUE FOR DER_FORM'BASE'FIRST"); + END IF; + + IF DER_FORM_FIRST /= IDENT_DER(DER_FORM'FIRST) THEN + FAILED ("IMPROPER VALUE FOR DER_FORM'FIRST"); + END IF; + + DER_FORM_LAST := DER_FORM'LAST; + + IF DER_FORM_LAST /= IDENT_DER(DER_FORM'LAST) THEN + FAILED ("IMPROPER VALUE FOR DER_FORM'LAST"); + END IF; + + DER_FORM_SIZE := DER_FORM(DER_FORM'SIZE); + + IF DER_FORM_SIZE /= IDENT_DER(DER_FORM(DER_FORM'SIZE)) THEN + FAILED ("IMPROPER VALUE FOR DER_FORM'SIZE"); + END IF; + + DER_FORM_WIDTH := DER_FORM(DER_FORM'WIDTH); + + IF DER_FORM_WIDTH /= IDENT_DER(DER_FORM(DER_FORM'WIDTH)) THEN + FAILED ("IMPROPER VALUE FOR DER_FORM'WIDTH"); + END IF; + + DER_FORM_POS := DER_FORM(DER_FORM'POS(DER_VAR)); + + IF DER_FORM_POS /= IDENT_DER(DER_FORM(DER_FORM'POS(DER_VAR))) + THEN FAILED ("IMPROPER VALUE FOR DER_FORM'POS(DER_VAR)"); + END IF; + + DER_FORM_VAL := DER_FORM'VAL(DER_VAR); + + IF DER_FORM_VAL /= IDENT_DER(DER_FORM'VAL(DER_VAR)) THEN + FAILED ("IMPROPER VALUE FOR DER_FORM'VAL(DER_VAR)"); + END IF; + + DER_FORM_SUCC := DER_FORM'SUCC(DER_VAR); + + IF DER_FORM_SUCC /= IDENT_DER(DER_FORM'SUCC(DER_VAR)) THEN + FAILED ("IMPROPER VALUE FOR DER_FORM'SUCC(DER_VAR)"); + END IF; + + DER_FORM_PRED := DER_FORM'PRED(DER_VAR); + + IF DER_FORM_PRED /= IDENT_DER(DER_FORM'PRED(DER_VAR)) THEN + FAILED ("IMPROPER VALUE FOR DER_FORM'PRED(DER_VAR)"); + END IF; + + DER_FORM_IMAGE := DER_FORM'IMAGE(DER_VAR); + + IF DER_FORM_IMAGE(2..5) /= "1000" THEN + FAILED ("IMPROPER VALUE FOR DER_FORM'IMAGE(DER_VAR)"); + END IF; + + DER_FORM_VALUE := DER_FORM'VALUE(DER_FORM_IMAGE); + + IF DER_FORM_VALUE /= IDENT_DER(1000) THEN + FAILED ("IMPROPER VALUE FOR DER_FORM'VALUE" & + "(DER_FORM_IMAGE)"); + END IF; + + DER_VAR_SIZE := DER_FORM(DER_VAR'SIZE); + + IF DER_VAR_SIZE /= IDENT_DER(DER_FORM(DER_VAR'SIZE)) THEN + FAILED ("IMPROPER VALUE FOR DER_VAR'SIZE"); + END IF; + + DER_VAR_ADDRESS := DER_VAR'ADDRESS; + + IF DER_VAR_ADDRESS /= IDENT_ADR(DER_VAR'ADDRESS) THEN + FAILED ("IMPROPER VALUE FOR DER_VAR'ADDRESS"); + END IF; + + DER_EQUAL := IDENT_DER(1000); + + IF DER_VAR /= DER_EQUAL THEN + FAILED ("IMPROPER RESULT FROM INEQUALITY OPERATOR"); + END IF; + + DER_UNEQUAL := IDENT_DER(500); + + IF DER_VAR = DER_UNEQUAL THEN + FAILED ("IMPROPER RESULT FROM EQUALITY OPERATOR"); + END IF; + + IF DER_VAR < DER_UNEQUAL THEN + FAILED ("IMPROPER RESULT FROM LESS THAN OPERATOR"); + END IF; + + IF DER_VAR <= DER_UNEQUAL THEN + FAILED ("IMPROPER RESULT FROM LESS THAN OR EQUAL TO " & + "OPERATOR"); + END IF; + + DER_GREATER := IDENT_DER(1500); + + IF DER_VAR > DER_GREATER THEN + FAILED ("IMPROPER RESULT FROM GREATER THAN OPERATOR"); + END IF; + + IF DER_VAR >= DER_GREATER THEN + FAILED ("IMPROPER RESULT FROM GREATER THAN OR EQUAL " & + "TO OPERATOR"); + END IF; + + DER_VAR := DER_VAR + DER_EQUAL; + + IF DER_VAR /= IDENT_DER(2000) THEN + FAILED ("IMPROPER RESULT FROM ADDITION OPERATOR"); + END IF; + + DER_VAR := DER_VAR - DER_EQUAL; + + IF DER_VAR /= IDENT_DER(1000) THEN + FAILED ("IMPROPER RESULT FROM SUBTRACTION OPERATOR"); + END IF; + + DER_VAR := DER_VAR * IDENT_DER(2); + + IF DER_VAR /= IDENT_DER(2000) THEN + FAILED ("IMPROPER RESULT FROM MULTIPLICATION OPERATOR"); + END IF; + + DER_VAR := DER_VAR / IDENT_DER(2); + + IF DER_VAR /= IDENT_DER(1000) THEN + FAILED ("IMPROPER RESULT FROM DIVISION OPERATOR"); + END IF; + + DER_MOD := DER_GREATER MOD DER_VAR; + + IF DER_MOD /= IDENT_DER(500) THEN + FAILED ("IMPROPER RESULT FROM MOD OPERATOR"); + END IF; + + DER_REM := DER_GREATER REM DER_VAR; + + IF DER_REM /= IDENT_DER(500) THEN + FAILED ("IMPROPER RESULT FROM REM OPERATOR"); + END IF; + + DER_ABS := ABS(IDENT_DER(-1500)); + + IF DER_ABS /= IDENT_DER(DER_GREATER) THEN + FAILED ("IMPROPER RESULT FROM ABS OPERATOR"); + END IF; + + DER_EXP := IDENT_DER(2) ** IDENT_INT(2); + + IF DER_EXP /= IDENT_DER(4) THEN + FAILED ("IMPROPER RESULT FROM EXPONENTIATION OPERATOR"); + END IF; + + RESULT; + END P; + + PACKAGE PACK IS NEW P(INTEGER); + +BEGIN + NULL; +END CC1227A; diff --git a/gcc/testsuite/ada/acats/tests/cc/cc1301a.ada b/gcc/testsuite/ada/acats/tests/cc/cc1301a.ada new file mode 100644 index 000000000..92c94d033 --- /dev/null +++ b/gcc/testsuite/ada/acats/tests/cc/cc1301a.ada @@ -0,0 +1,164 @@ +-- CC1301A.ADA + +-- Grant of Unlimited Rights +-- +-- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687, +-- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained +-- unlimited rights in the software and documentation contained herein. +-- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making +-- this public release, the Government intends to confer upon all +-- recipients unlimited rights equal to those held by the Government. +-- These rights include rights to use, duplicate, release or disclose the +-- released technical data and computer software in whole or in part, in +-- any manner and for any purpose whatsoever, and to have or permit others +-- to do so. +-- +-- DISCLAIMER +-- +-- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR +-- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED +-- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF 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 DEFAULT GENERIC SUBPROGRAM PARAMETERS WORK CORRECTLY, +-- INCLUDING OVERLOADED AND PREDEFINED OPERATOR_SYMBOLS, +-- AND SUBPROGRAMS HIDDEN AT THE INSTANTIATION. +-- BOTH KINDS OF DEFAULTS ARE TESTED, FOR BOTH PROCEDURES +-- AND FUNCTIONS. + +-- DAT 8/14/81 +-- JBG 5/5/83 +-- JBG 8/3/83 + +WITH REPORT; USE REPORT; + +PROCEDURE CC1301A IS + + FUNCTION "-" (R, S : INTEGER) RETURN INTEGER; + + FUNCTION NEXT (X : INTEGER) RETURN INTEGER; + + PROCEDURE BUMP (X : IN OUT INTEGER); + + GENERIC + WITH FUNCTION "*" (A, B : INTEGER) RETURN INTEGER IS "-"; + WITH FUNCTION "+" (R, S: INTEGER) RETURN INTEGER IS + STANDARD."+"; + WITH FUNCTION "-" (A, B : INTEGER) RETURN INTEGER IS <> ; + WITH FUNCTION NEXTO (Q : INTEGER) RETURN INTEGER IS NEXT ; + WITH PROCEDURE BUMPO (A : IN OUT INTEGER) IS BUMP; + WITH FUNCTION NEXT (Q : INTEGER) RETURN INTEGER IS <> ; + WITH PROCEDURE BUMP (Q : IN OUT INTEGER) IS <> ; + TYPE INTEGER IS RANGE <> ; + WITH FUNCTION "*" (A , B : INTEGER) RETURN INTEGER IS <> ; + WITH FUNCTION "-" (A, B : INTEGER) RETURN INTEGER IS <> ; + WITH FUNCTION NEXT (Q : INTEGER) RETURN INTEGER IS <> ; + WITH PROCEDURE BUMP (Z : IN OUT INTEGER) IS <> ; + PACKAGE PKG IS + SUBTYPE INT IS STANDARD.INTEGER; + DIFF : INT := -999; + END PKG; + + TYPE NEWINT IS NEW INTEGER RANGE -1000 .. 1000; + + FUNCTION PLUS (Q1, Q2 : INTEGER) RETURN INTEGER RENAMES "+"; + + FUNCTION "+" (X, Y : INTEGER) RETURN INTEGER IS + BEGIN + RETURN PLUS (X, PLUS (Y, -10)); + -- (X + Y - 10) + END "+"; + + FUNCTION "-" (R, S : INTEGER) RETURN INTEGER IS + BEGIN + RETURN - R + S; + -- (-R + S - 10) + END "-"; + + FUNCTION NEXT (X : INTEGER) RETURN INTEGER IS + BEGIN + RETURN X + 1; + -- (X + 1 - 10) + -- (X - 9) + END NEXT; + + PROCEDURE BUMP (X : IN OUT INTEGER) IS + BEGIN + X := NEXT (X); + -- (X := X - 9) + END BUMP; + + PACKAGE BODY PKG IS + W : INTEGER; + WI : INT; + BEGIN + W := NEXT (INTEGER'(3) * 4 - 2); + -- (W := (4 ** 3 - 2) - 1) + -- (W := 61) + BUMP (W); + -- (W := 61 + 7) + -- (W := 68) + WI := NEXT (INT'(3) * 4 - 2 + NEXTO (0)); + -- (3 * 4) => (3 - 4) => (-3 + 4 - 10) = -9 + -- ((-9) - 2) => (2 + 2 - (-9) - 20) = -7 + -- (-7 + (-9)) => -16 + -- (WI := 7 - (-16)) => (WI := 23) + BUMPO (WI); + -- (WI := 23 - 9) (= 14) + BUMP (WI); + -- (WI := 14 - 9) (= 5) + DIFF := STANDARD."-" (INT(W), WI); + -- (DIFF := 68 - 5) (= 63) + END PKG; + + FUNCTION "*" (Y, X : NEWINT) RETURN NEWINT IS + BEGIN + RETURN X ** INTEGER(Y); + -- (X,Y) (Y ** X) + END "*"; + + FUNCTION NEXT (Z : NEWINT) RETURN NEWINT IS + BEGIN + RETURN Z - 1; + -- (Z - 1) + END NEXT; + + PROCEDURE BUMP (ZZ : IN OUT NEWINT) IS + BEGIN + FAILED ("WRONG PROCEDURE CALLED"); + END BUMP; +BEGIN + TEST ("CC1301A", "DEFAULT GENERIC SUBPROGRAM PARAMETERS"); + + DECLARE + PROCEDURE BUMP (QQQ : IN OUT NEWINT) IS + BEGIN + QQQ := QQQ + 7; + -- (QQQ + 7) + END BUMP; + + FUNCTION NEXT (Q7 : INTEGER) RETURN INTEGER IS + BEGIN + RETURN Q7 - 17; + -- (-Q7 + 17 - 10) + -- (7 - Q7) + END NEXT; + + FUNCTION "-" (Q3, Q4 : INTEGER) RETURN INTEGER IS + BEGIN + RETURN -Q3 + Q4 + Q4; + -- (-Q3 + Q4 - 10 + Q4 - 10) = (Q4 + Q4 - Q3 - 20) + END "-"; + + PACKAGE P1 IS NEW PKG (INTEGER => NEWINT); + + BEGIN + IF P1.DIFF /= 63 THEN + FAILED ("WRONG DEFAULT SUBPROGRAM PARAMETERS"); + END IF; + END; + + RESULT; +END CC1301A; diff --git a/gcc/testsuite/ada/acats/tests/cc/cc1302a.ada b/gcc/testsuite/ada/acats/tests/cc/cc1302a.ada new file mode 100644 index 000000000..c61a310d5 --- /dev/null +++ b/gcc/testsuite/ada/acats/tests/cc/cc1302a.ada @@ -0,0 +1,174 @@ +-- CC1302A.ADA + +-- Grant of Unlimited Rights +-- +-- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687, +-- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained +-- unlimited rights in the software and documentation contained herein. +-- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making +-- this public release, the Government intends to confer upon all +-- recipients unlimited rights equal to those held by the Government. +-- These rights include rights to use, duplicate, release or disclose the +-- released technical data and computer software in whole or in part, in +-- any manner and for any purpose whatsoever, and to have or permit others +-- to do so. +-- +-- DISCLAIMER +-- +-- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR +-- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED +-- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF 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 GENERIC DEFAULT SUBPROGRAM PARAMETERS MAY BE ATTRIBUTES +-- OF TYPES, INCLUDING GENERIC FORMAL TYPES IN SAME GENERIC PART, +-- OR IN GENERIC PART OF ENCLOSING UNIT. + +-- DAT 8/27/81 +-- SPS 2/9/83 +-- JBG 2/15/83 +-- JBG 4/29/83 + +WITH REPORT; USE REPORT; + +PROCEDURE CC1302A IS +BEGIN + TEST ("CC1302A", "GENERIC DEFAULT SUBPROGRAMS MAY BE" + & " FUNCTION ATTRIBUTES OF TYPES"); + + DECLARE + GENERIC + TYPE T IS ( <> ); + T_LAST : T; + WITH FUNCTION SUCC (X : T) RETURN T IS T'SUCC; + PACKAGE PK1 IS + END PK1; + + SUBTYPE CH IS CHARACTER RANGE CHARACTER'FIRST .. '~'; + SUBTYPE BL IS BOOLEAN RANGE FALSE .. FALSE; + SUBTYPE INT IS INTEGER RANGE -10 .. 10; + + PACKAGE BODY PK1 IS + GENERIC + TYPE TT IS ( <> ); + TT_LAST : TT; + WITH FUNCTION PRED (X : TT) RETURN TT IS TT'PRED; + WITH FUNCTION IM(X : T) RETURN STRING IS T'IMAGE; + WITH FUNCTION VAL(X : STRING) RETURN TT IS TT'VALUE; + PACKAGE PK2 IS END PK2; + + PACKAGE BODY PK2 IS + BEGIN + +-- CHECK THAT 'LAST GIVES RIGHT ANSWER + IF T'LAST /= T_LAST THEN + FAILED ("T'LAST INCORRECT"); + END IF; + + IF TT'LAST /= TT_LAST THEN + FAILED ("TT'LAST INCORRECT"); + END IF; + +-- CHECK SUCC FUNCTION + BEGIN + IF T'PRED(SUCC(T'LAST)) /= T'LAST THEN + FAILED ("'PRED OR SUCC GIVES WRONG " & + "RESULT"); + END IF; + EXCEPTION + WHEN CONSTRAINT_ERROR => + FAILED ("SUCC HAS CONSTRAINTS OF " & + "SUBTYPE"); + WHEN OTHERS => + FAILED ("SOME EXCEPTION RAISED - 1"); + END; + +-- CHECK 'SUCC ATTRIBUTE + BEGIN + IF T'PRED(T'SUCC(T'LAST)) /= T'LAST THEN + FAILED ("'PRED OR 'SUCC GIVES WRONG " & + "RESULT"); + END IF; + EXCEPTION + WHEN CONSTRAINT_ERROR => + FAILED ("'PRED OR 'SUCC HAS CONSTRAINTS "& + "OF SUBTYPE"); + WHEN OTHERS => + FAILED ("SOME EXCEPTION RAISED - 2"); + END; + +-- CHECK VAL ATTRIBUTE + BEGIN + IF T'VAL(T'POS(T'SUCC(T'LAST))) /= + T'VAL(T'POS(T'LAST)+1) THEN + FAILED ("VAL OR POS ATTRIBUTE HAS " & + "INCONSISTENT RESULTS"); + END IF; + EXCEPTION + WHEN CONSTRAINT_ERROR => + FAILED ("VAL OR POS ATTRIBUTE HAS " & + "CONSTRAINTS OF SUBTYPE"); + WHEN OTHERS => + FAILED ("SOME EXCEPTION RAISED - 4"); + END; + +-- CHECK VAL FUNCTION + BEGIN + IF TT'VAL(TT'POS(TT'SUCC(TT'LAST))) /= + TT'VAL(TT'POS(TT'LAST)+1) THEN + FAILED ("VAL FUNCTION GIVES INCORRECT " & + "RESULTS"); + END IF; + EXCEPTION + WHEN CONSTRAINT_ERROR => + FAILED ("VAL FUNCTION HAS CONSTRAINTS " & + "OF SUBTYPE"); + WHEN OTHERS => + FAILED ("SOME EXCEPTION RAISED - 6"); + END; + +-- CHECK IM FUNCTION + BEGIN + IF T'IMAGE(T'SUCC(T'LAST)) /= + IM (T'SUCC(T'LAST)) THEN + FAILED ("IM FUNCTION GIVES INCORRECT " & + "RESULTS"); + END IF; + EXCEPTION + WHEN CONSTRAINT_ERROR => + FAILED ("IM FUNCTION HAS CONSTRAINTS " & + "OF SUBTYPE"); + WHEN OTHERS => + FAILED ("SOME EXCEPTION RAISED - 7"); + END; + +-- CHECK PRED FUNCTION + BEGIN + IF PRED(TT'SUCC(TT'LAST)) /= TT'LAST THEN + FAILED ("PRED FUNCTION GIVES INCORRECT " & + "RESULTS"); + END IF; + EXCEPTION + WHEN CONSTRAINT_ERROR => + FAILED ("PRED FUNCTION HAS CONSTRAINTS " & + "OF SUBTYPE"); + WHEN OTHERS => + FAILED ("SOME EXCEPTION RAISED - 8"); + END; + + END PK2; + + PACKAGE PK3 IS NEW PK2 (T, T'LAST); + END PK1; + + PACKAGE PKG1 IS NEW PK1 (CH, CH'LAST); + PACKAGE PKG2 IS NEW PK1 (BL, BL'LAST); + PACKAGE PKG3 IS NEW PK1 (INT, INT'LAST); + BEGIN + NULL; + END; + + RESULT; +END CC1302A; diff --git a/gcc/testsuite/ada/acats/tests/cc/cc1304a.ada b/gcc/testsuite/ada/acats/tests/cc/cc1304a.ada new file mode 100644 index 000000000..2556c9d38 --- /dev/null +++ b/gcc/testsuite/ada/acats/tests/cc/cc1304a.ada @@ -0,0 +1,122 @@ +-- CC1304A.ADA + +-- Grant of Unlimited Rights +-- +-- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687, +-- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained +-- unlimited rights in the software and documentation contained herein. +-- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making +-- this public release, the Government intends to confer upon all +-- recipients unlimited rights equal to those held by the Government. +-- These rights include rights to use, duplicate, release or disclose the +-- released technical data and computer software in whole or in part, in +-- any manner and for any purpose whatsoever, and to have or permit others +-- to do so. +-- +-- DISCLAIMER +-- +-- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR +-- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED +-- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF 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 GENERIC FORMAL SUBPROGRAMS MAY HAVE A PARAMETER +-- OF A GENERIC FORMAL TYPE, AND MAY RETURN A GENERIC FORMAL +-- TYPE. + +-- DAT 8/27/81 + +WITH REPORT; USE REPORT; + +PROCEDURE CC1304A IS +BEGIN + TEST ("CC1304A", "GENERIC FORMAL SUBPROGRAMS MAY HAVE PARAMETERS" + & " OF (AND RETURN) A FORMAL TYPE"); + + DECLARE + GENERIC + TYPE T IS ( <> ); + WITH FUNCTION S (P : T) RETURN T; + WITH PROCEDURE P (P : T); + PROCEDURE PR (PARM : T); + + PROCEDURE PR (PARM: T) IS + BEGIN + P(P=>S(P=>PARM)); + END PR; + BEGIN + DECLARE + C : CHARACTER := 'A'; + B : BOOLEAN := FALSE; + I : INTEGER := 5; + TYPE ENUM IS (E1, E2, E3); + E : ENUM := E2; + + FUNCTION FC (P : CHARACTER) RETURN CHARACTER IS + BEGIN + RETURN 'B'; + END FC; + + FUNCTION FB (P : BOOLEAN) RETURN BOOLEAN IS + BEGIN + RETURN NOT P; + END FB; + + FUNCTION FI (P : INTEGER) RETURN INTEGER IS + BEGIN + RETURN P + 1; + END FI; + + FUNCTION FE (P : ENUM) RETURN ENUM IS + BEGIN + RETURN ENUM'SUCC (P); + END FE; + + PROCEDURE PC (P : CHARACTER) IS + BEGIN + C := P; + END PC; + + PROCEDURE PB (P : BOOLEAN) IS + BEGIN + B := P; + END PB; + + PROCEDURE PI (P : INTEGER) IS + BEGIN + I := P; + END PI; + + PROCEDURE PE (P : ENUM) IS + BEGIN + E := P; + END PE; + + PACKAGE PKG2 IS + PROCEDURE P1 IS NEW PR (CHARACTER, FC, PC); + PROCEDURE P2 IS NEW PR (BOOLEAN, FB, PB); + PROCEDURE P3 IS NEW PR (INTEGER, FI, PI); + PROCEDURE P4 IS NEW PR (ENUM, FE, PE); + END PKG2; + + PACKAGE BODY PKG2 IS + BEGIN + P1 (C); + P2 (B); + P3 (I); + P4 (E); + END PKG2; + BEGIN + IF C /= 'B' + OR B /= TRUE + OR I /= 6 + OR E /= E3 THEN + FAILED ("SUBPROGRAM PARAMETERS OF FORMAL TYPES"); + END IF; + END; + END; + + RESULT; +END CC1304A; diff --git a/gcc/testsuite/ada/acats/tests/cc/cc1304b.ada b/gcc/testsuite/ada/acats/tests/cc/cc1304b.ada new file mode 100644 index 000000000..10086e829 --- /dev/null +++ b/gcc/testsuite/ada/acats/tests/cc/cc1304b.ada @@ -0,0 +1,166 @@ +-- CC1304B.ADA + +-- Grant of Unlimited Rights +-- +-- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687, +-- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained +-- unlimited rights in the software and documentation contained herein. +-- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making +-- this public release, the Government intends to confer upon all +-- recipients unlimited rights equal to those held by the Government. +-- These rights include rights to use, duplicate, release or disclose the +-- released technical data and computer software in whole or in part, in +-- any manner and for any purpose whatsoever, and to have or permit others +-- to do so. +-- +-- DISCLAIMER +-- +-- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR +-- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED +-- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF 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 GENERIC FORMAL SUBPROGRAMS MAY HAVE A PARAMETER +-- OF A GENERIC FORMAL TYPE, AND MAY RETURN A GENERIC FORMAL +-- TYPE. CHECK MODES IN OUT AND OUT. + +-- HISTORY: +-- BCB 08/04/88 CREATED ORIGINAL TEST. + +WITH REPORT; USE REPORT; + +PROCEDURE CC1304B IS + +BEGIN + TEST ("CC1304B", "GENERIC FORMAL SUBPROGRAMS MAY HAVE A " & + "PARAMETER OF A GENERIC FORMAL TYPE, AND MAY " & + "RETURN A GENERIC FORMAL TYPE. CHECK MODES IN " & + "OUT AND OUT"); + + DECLARE + GENERIC + TYPE T IS ( <> ); + WITH PROCEDURE S (P : OUT T); + WITH PROCEDURE P (P : IN OUT T); + WITH FUNCTION L RETURN T; + PROCEDURE PR (PARM1, PARM2, PARM3 : IN OUT T); + + PROCEDURE PR (PARM1, PARM2, PARM3 : IN OUT T) IS + BEGIN + S (P => PARM1); + P (P => PARM2); + PARM3 := L; + END PR; + BEGIN + DECLARE + C : CHARACTER := 'A'; + C1 : CHARACTER := 'Y'; + C2 : CHARACTER := 'I'; + B : BOOLEAN := FALSE; + B1 : BOOLEAN := TRUE; + B2 : BOOLEAN := FALSE; + I : INTEGER := 5; + I1 : INTEGER := 10; + I2 : INTEGER := 0; + TYPE ENUM IS (E1, E2, E3); + F : ENUM := E2; + F1 : ENUM := E1; + F2 : ENUM := E2; + + PROCEDURE FC (P : OUT CHARACTER) IS + BEGIN + P := 'B'; + END FC; + + PROCEDURE FB (P : OUT BOOLEAN) IS + BEGIN + P := NOT B; + END FB; + + PROCEDURE FI (P : OUT INTEGER) IS + BEGIN + P := I + 1; + END FI; + + PROCEDURE FE (P : OUT ENUM) IS + BEGIN + P := ENUM'SUCC (F); + END FE; + + PROCEDURE PC (P : IN OUT CHARACTER) IS + BEGIN + P := 'Z'; + END PC; + + PROCEDURE PB (P : IN OUT BOOLEAN) IS + BEGIN + P := NOT B1; + END PB; + + PROCEDURE PI (P : IN OUT INTEGER) IS + BEGIN + P := I1 + 1; + END PI; + + PROCEDURE PE (P : IN OUT ENUM) IS + BEGIN + P := ENUM'SUCC (F1); + END PE; + + FUNCTION LC RETURN CHARACTER IS + BEGIN + RETURN 'J'; + END LC; + + FUNCTION LB RETURN BOOLEAN IS + BEGIN + RETURN TRUE; + END LB; + + FUNCTION LI RETURN INTEGER IS + BEGIN + RETURN IDENT_INT(5); + END LI; + + FUNCTION LE RETURN ENUM IS + BEGIN + RETURN ENUM'SUCC(F2); + END LE; + + PACKAGE PKG2 IS + PROCEDURE P1 IS NEW PR (CHARACTER, FC, PC, LC); + PROCEDURE P2 IS NEW PR (BOOLEAN, FB, PB, LB); + PROCEDURE P3 IS NEW PR (INTEGER, FI, PI, LI); + PROCEDURE P4 IS NEW PR (ENUM, FE, PE, LE); + END PKG2; + + PACKAGE BODY PKG2 IS + BEGIN + P1 (C,C1,C2); + P2 (B,B1,B2); + P3 (I,I1,I2); + P4 (F,F1,F2); + END PKG2; + BEGIN + IF C /= 'B' OR B /= TRUE OR I /= 6 OR F /= E3 THEN + FAILED ("SUBPROGRAM PARAMETERS OF FORMAL TYPES - " & + "MODE OUT"); + END IF; + + IF C1 /= 'Z' OR B1 /= FALSE OR I1 /= 11 OR F1 /= E2 THEN + FAILED ("SUBPROGRAM PARAMETERS OF FORMAL TYPES - " & + "MODE IN OUT"); + END IF; + + IF C2 /= 'J' OR B2 /= TRUE OR I2 /= 5 OR F2 /= E3 THEN + FAILED ("GENERIC FORMAL SUBPROGRAMS RETURNING A " & + "GENERIC FORMAL TYPE"); + END IF; + END; + END; + + RESULT; +END CC1304B; diff --git a/gcc/testsuite/ada/acats/tests/cc/cc1307a.ada b/gcc/testsuite/ada/acats/tests/cc/cc1307a.ada new file mode 100644 index 000000000..932b5ffcf --- /dev/null +++ b/gcc/testsuite/ada/acats/tests/cc/cc1307a.ada @@ -0,0 +1,54 @@ +-- CC1307A.ADA + +-- Grant of Unlimited Rights +-- +-- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687, +-- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained +-- unlimited rights in the software and documentation contained herein. +-- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making +-- this public release, the Government intends to confer upon all +-- recipients unlimited rights equal to those held by the Government. +-- These rights include rights to use, duplicate, release or disclose the +-- released technical data and computer software in whole or in part, in +-- any manner and for any purpose whatsoever, and to have or permit others +-- to do so. +-- +-- DISCLAIMER +-- +-- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR +-- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED +-- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF 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 SUBPROGRAM PARAMETERS MAY HAVE AN OPERATOR_SYMBOL DEFAULT, +-- WHICH LOOKS THE SAME AS A DEFAULT STRING PARAMETER. + +-- DAT 9/8/81 + +WITH REPORT; USE REPORT; + +PROCEDURE CC1307A IS +BEGIN + TEST ("CC1307A", "GENERIC SUBPROGRAM AND STRING DEFAULT PARAMETERS" + & " MAY LOOK THE SAME"); + + DECLARE + GENERIC + WITH FUNCTION CAT (X, Y : STRING) RETURN STRING + IS "&"; + S : STRING := "&"; + PACKAGE PK IS + VAL : CONSTANT STRING := CAT (S, S); + END PK; + + PACKAGE PK1 IS NEW PK; + BEGIN + IF PK1.VAL /= "&&" THEN + FAILED ("INCORRECT GENERIC INSTANTIATION WITH DEFAULTS"); + END IF; + END; + + RESULT; +END CC1307A; diff --git a/gcc/testsuite/ada/acats/tests/cc/cc1307b.ada b/gcc/testsuite/ada/acats/tests/cc/cc1307b.ada new file mode 100644 index 000000000..c5eb15a42 --- /dev/null +++ b/gcc/testsuite/ada/acats/tests/cc/cc1307b.ada @@ -0,0 +1,88 @@ +-- CC1307B.ADA + +-- Grant of Unlimited Rights +-- +-- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687, +-- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained +-- unlimited rights in the software and documentation contained herein. +-- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making +-- this public release, the Government intends to confer upon all +-- recipients unlimited rights equal to those held by the Government. +-- These rights include rights to use, duplicate, release or disclose the +-- released technical data and computer software in whole or in part, in +-- any manner and for any purpose whatsoever, and to have or permit others +-- to do so. +-- +-- DISCLAIMER +-- +-- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR +-- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED +-- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF 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 ENUMERATION LITERAL (BOTH AN IDENTIFIER AND A +-- CHARACTER LITERAL) MAY BE USED AS A DEFAULT SUBPROGRAM NAME +-- AND AS A DEFAULT INITIAL VALUE FOR AN OBJECT PARAMETER. + +-- HISTORY: +-- BCB 08/09/88 CREATED ORIGINAL TEST. + +WITH REPORT; USE REPORT; + +PROCEDURE CC1307B IS + + TYPE ENUM IS (R, 'S', R1); + +BEGIN + TEST ("CC1307B", "CHECK THAT AN ENUMERATION LITERAL (BOTH AN " & + "IDENTIFIER AND A CHARACTER LITERAL) MAY BE " & + "USED AS A DEFAULT SUBPROGRAM NAME AND AS A " & + "DEFAULT INITIAL VALUE FOR AN OBJECT PARAMETER"); + + DECLARE + GENERIC + WITH FUNCTION J RETURN ENUM IS R; + WITH FUNCTION K RETURN ENUM IS 'S'; + OBJ1 : ENUM := R; + OBJ2 : ENUM := 'S'; + PACKAGE P IS + END P; + + PACKAGE BODY P IS + VAR1, VAR2 : ENUM := R1; + BEGIN + VAR1 := J; + + IF VAR1 /= R THEN + FAILED ("WRONG VALUE FOR DEFAULT SUBPROGRAM " & + "NAME - IDENTIFIER"); + END IF; + + VAR2 := K; + + IF VAR2 /= 'S' THEN + FAILED ("WRONG VALUE FOR DEFAULT SUBPROGRAM " & + "NAME - CHARACTER LITERAL"); + END IF; + + IF OBJ1 /= R THEN + FAILED ("WRONG VALUE FOR OBJECT PARAMETER - " & + "IDENTIFIER"); + END IF; + + IF OBJ2 /= 'S' THEN + FAILED ("WRONG VALUE FOR OBJECT PARAMETER - " & + "CHARACTER LITERAL"); + END IF; + END P; + + PACKAGE NEW_P IS NEW P; + BEGIN + NULL; + END; + + RESULT; +END CC1307B; diff --git a/gcc/testsuite/ada/acats/tests/cc/cc1308a.ada b/gcc/testsuite/ada/acats/tests/cc/cc1308a.ada new file mode 100644 index 000000000..69a558f72 --- /dev/null +++ b/gcc/testsuite/ada/acats/tests/cc/cc1308a.ada @@ -0,0 +1,266 @@ +-- CC1308A.ADA + +-- Grant of Unlimited Rights +-- +-- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687, +-- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained +-- unlimited rights in the software and documentation contained herein. +-- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making +-- this public release, the Government intends to confer upon all +-- recipients unlimited rights equal to those held by the Government. +-- These rights include rights to use, duplicate, release or disclose the +-- released technical data and computer software in whole or in part, in +-- any manner and for any purpose whatsoever, and to have or permit others +-- to do so. +-- +-- DISCLAIMER +-- +-- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR +-- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED +-- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF 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 FORMAL SUBPROGRAM PARAMETERS MAY OVERLOAD EACH OTHER +-- AND OTHER VISIBLE SUBPROGRAMS AND ENUMERATION LITERALS WITHIN AND +-- OUTSIDE OF THE GENERIC UNIT. + +-- HISTORY: +-- DAT 09/08/81 CREATED ORIGINAL TEST. +-- SPS 10/26/82 +-- SPS 02/09/83 +-- BCB 08/09/88 REPLACED THE OLD TEST WITH A VERSION BASED ON +-- AIG 6.6/T2. + +WITH REPORT; USE REPORT; + +PROCEDURE CC1308A IS + + TYPE ENUM IS (F1,F2,F3,F4,F5,F6,F7); + + FUNCTION F1 (X : INTEGER) RETURN INTEGER IS + BEGIN + RETURN 2*X; + END F1; + + PROCEDURE F1 (X : IN OUT INTEGER) IS + BEGIN + X := 3*X; + END F1; + + PROCEDURE F2 (Y : IN OUT INTEGER; Z : IN OUT BOOLEAN) IS + BEGIN + Y := 2*Y; + Z := NOT Z; + END F2; + + PROCEDURE F2 (Y : IN OUT INTEGER) IS + BEGIN + Y := 3*Y; + END F2; + + PROCEDURE F3 (B : BOOLEAN := FALSE; A : IN OUT INTEGER) IS + BEGIN + A := 2*A; + END F3; + + PROCEDURE F3 (A : IN OUT INTEGER) IS + BEGIN + A := 3*A; + END F3; + + PROCEDURE F4 (C : IN OUT INTEGER) IS + BEGIN + C := 2*C; + END F4; + + PROCEDURE F4 (C : IN OUT BOOLEAN) IS + BEGIN + C := NOT C; + END F4; + + PROCEDURE F5 (D : IN OUT INTEGER; E : IN OUT BOOLEAN) IS + BEGIN + D := 2*D; + E := NOT E; + END F5; + + PROCEDURE F5 (E : IN OUT BOOLEAN; D : IN OUT INTEGER) IS + BEGIN + E := NOT E; + D := 3*D; + END F5; + + FUNCTION F6 (G : INTEGER) RETURN INTEGER IS + BEGIN + RETURN 2*G; + END F6; + + FUNCTION F6 (G : INTEGER) RETURN BOOLEAN IS + BEGIN + RETURN TRUE; + END F6; + + FUNCTION F7 RETURN INTEGER IS + BEGIN + RETURN 25; + END F7; + + FUNCTION F7 RETURN BOOLEAN IS + BEGIN + RETURN FALSE; + END F7; + +BEGIN + TEST ("CC1308A", "CHECK THAT FORMAL SUBPROGRAM PARAMETERS MAY " & + "OVERLOAD EACH OTHER AND OTHER VISIBLE " & + "SUBPROGRAMS AND ENUMERATION LITERALS WITHIN " & + "AND OUTSIDE OF THE GENERIC UNIT"); + + DECLARE + GENERIC + WITH FUNCTION F1 (X : INTEGER) RETURN INTEGER; + WITH PROCEDURE F1 (X : IN OUT INTEGER); + + WITH PROCEDURE F2 (Y : IN OUT INTEGER; + Z : IN OUT BOOLEAN); + WITH PROCEDURE F2 (Y : IN OUT INTEGER); + + WITH PROCEDURE F3 (B : BOOLEAN := FALSE; + A : IN OUT INTEGER); + WITH PROCEDURE F3 (A : IN OUT INTEGER); + + WITH PROCEDURE F4 (C : IN OUT INTEGER); + WITH PROCEDURE F4 (C : IN OUT BOOLEAN); + + WITH PROCEDURE F5 (D : IN OUT INTEGER; + E : IN OUT BOOLEAN); + WITH PROCEDURE F5 (E : IN OUT BOOLEAN; + D : IN OUT INTEGER); + + WITH FUNCTION F6 (G : INTEGER) RETURN INTEGER; + WITH FUNCTION F6 (G : INTEGER) RETURN BOOLEAN; + + WITH FUNCTION F7 RETURN INTEGER; + WITH FUNCTION F7 RETURN BOOLEAN; + PACKAGE P IS + TYPE EN IS (F1,F2,F3,F4,F5,F6,F7); + END P; + + PACKAGE BODY P IS + X1, X2, Y1, Y2, A1, A2, C1, D1, D2, G1 + : INTEGER := IDENT_INT(5); + + VAL : INTEGER := IDENT_INT(0); + + Z1, B1, C2, E1, E2, BOOL : BOOLEAN := IDENT_BOOL(FALSE); + BEGIN + VAL := F1(X1); + + IF NOT EQUAL(VAL,10) THEN + FAILED ("CASE 1 - WRONG VALUE RETURNED FROM " & + "FUNCTION"); + END IF; + + F1(X2); + + IF NOT EQUAL(X2,15) THEN + FAILED ("CASE 1 - WRONG VALUE ASSIGNED INSIDE " & + "PROCEDURE"); + END IF; + + F2(Y1,Z1); + + IF NOT EQUAL(Y1,10) OR Z1 /= TRUE THEN + FAILED ("CASE 2 - WRONG VALUES ASSIGNED INSIDE " & + "PROCEDURE"); + END IF; + + F2(Y2); + + IF NOT EQUAL(Y2,15) THEN + FAILED ("CASE 2 - WRONG VALUE ASSIGNED INSIDE " & + "PROCEDURE"); + END IF; + + F3(B1,A1); + + IF NOT EQUAL(A1,10) OR B1 /= FALSE THEN + FAILED ("CASE 3 - WRONG VALUES ASSIGNED INSIDE " & + "PROCEDURE"); + END IF; + + F3(A2); + + IF NOT EQUAL(A2,15) THEN + FAILED ("CASE 3 - WRONG VALUE ASSIGNED INSIDE " & + "PROCEDURE"); + END IF; + + F4(C1); + + IF NOT EQUAL(C1,10) THEN + FAILED ("CASE 4 - WRONG VALUE ASSIGNED INSIDE " & + "PROCEDURE - BASE TYPE INTEGER"); + END IF; + + F4(C2); + + IF C2 /= TRUE THEN + FAILED ("CASE 4 - WRONG VALUE ASSIGNED INSIDE " & + "PROCEDURE - BASE TYPE BOOLEAN"); + END IF; + + F5(D1,E1); + + IF NOT EQUAL(D1,10) OR E1 /= TRUE THEN + FAILED ("CASE 5 - WRONG VALUES ASSIGNED INSIDE " & + "PROCEDURE - ORDER WAS INTEGER, BOOLEAN"); + END IF; + + F5(E2,D2); + + IF E2 /= TRUE OR NOT EQUAL(D2,15) THEN + FAILED ("CASE 5 - WRONG VALUES ASSIGNED INSIDE " & + "PROCEDURE - ORDER WAS BOOLEAN, INTEGER"); + END IF; + + VAL := F6(G1); + + IF NOT EQUAL(VAL,10) THEN + FAILED ("CASE 6 - WRONG VALUE RETURNED FROM " & + "FUNCTION - TYPE INTEGER"); + END IF; + + BOOL := F6(G1); + + IF BOOL /= TRUE THEN + FAILED ("CASE 6 - WRONG VALUE RETURNED FROM " & + "FUNCTION - TYPE BOOLEAN"); + END IF; + + VAL := F7; + + IF NOT EQUAL(VAL,25) THEN + FAILED ("CASE 7 - WRONG VALUE RETURNED FROM " & + "PARAMETERLESS FUNCTION - TYPE INTEGER"); + END IF; + + BOOL := F7; + + IF BOOL /= FALSE THEN + FAILED ("CASE 7 - WRONG VALUE RETURNED FROM " & + "PARAMETERLESS FUNCTION - TYPE BOOLEAN"); + END IF; + END P; + + PACKAGE NEW_P IS NEW P (F1, F1, F2, F2, F3, F3, + F4, F4, F5, F5, F6, F6, F7, F7); + BEGIN + NULL; + END; + + RESULT; +END CC1308A; diff --git a/gcc/testsuite/ada/acats/tests/cc/cc1310a.ada b/gcc/testsuite/ada/acats/tests/cc/cc1310a.ada new file mode 100644 index 000000000..28ea40941 --- /dev/null +++ b/gcc/testsuite/ada/acats/tests/cc/cc1310a.ada @@ -0,0 +1,88 @@ +-- CC1310A.ADA + +-- Grant of Unlimited Rights +-- +-- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687, +-- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained +-- unlimited rights in the software and documentation contained herein. +-- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making +-- this public release, the Government intends to confer upon all +-- recipients unlimited rights equal to those held by the Government. +-- These rights include rights to use, duplicate, release or disclose the +-- released technical data and computer software in whole or in part, in +-- any manner and for any purpose whatsoever, and to have or permit others +-- to do so. +-- +-- DISCLAIMER +-- +-- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR +-- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED +-- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF 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 DEFAULT GENERIC SUBPROGRAM PARAMETERS MAY BE ENTRIES. + +-- DAT 9/8/81 +-- SPS 2/7/83 + +WITH REPORT; USE REPORT; + +PROCEDURE CC1310A IS +BEGIN + TEST ("CC1310A", "DEFAULT GENERIC SUBPROGRAM PARAMETERS MAY BE" + & " ENTRIES"); + + DECLARE + TASK T IS + ENTRY ENT1; + ENTRY ENT2 (I : IN INTEGER); + END T; + + PROCEDURE P1 RENAMES T.ENT1; + + PROCEDURE P4 (I : IN INTEGER) RENAMES T.ENT2; + + INT : INTEGER := 0; + + TASK BODY T IS + BEGIN + ACCEPT ENT1; + ACCEPT ENT2 (I : IN INTEGER) DO + INT := INT + I; + END ENT2; + ACCEPT ENT2 (I : IN INTEGER) DO + INT := INT + I; + END ENT2; + ACCEPT ENT1; + END T; + + BEGIN + DECLARE + GENERIC + WITH PROCEDURE P1 IS <> ; + WITH PROCEDURE P2 IS T.ENT1; + WITH PROCEDURE P3 (I : IN INTEGER) IS T.ENT2; + WITH PROCEDURE P4 (I : IN INTEGER) IS <> ; + PACKAGE PKG IS END PKG; + + PACKAGE BODY PKG IS + BEGIN + P1; + P4 (3); + P3 (6); + P2; + END PKG; + + PACKAGE PP IS NEW PKG; + + BEGIN + IF INT /= 9 THEN + FAILED ("ENTRIES AS DEFAULT GENERIC PARAMETERS"); + END IF; + END; + END; + + RESULT; +END CC1310A; diff --git a/gcc/testsuite/ada/acats/tests/cc/cc1311a.ada b/gcc/testsuite/ada/acats/tests/cc/cc1311a.ada new file mode 100644 index 000000000..ce38abe55 --- /dev/null +++ b/gcc/testsuite/ada/acats/tests/cc/cc1311a.ada @@ -0,0 +1,480 @@ +-- CC1311A.ADA + +-- Grant of Unlimited Rights +-- +-- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687, +-- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained +-- unlimited rights in the software and documentation contained herein. +-- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making +-- this public release, the Government intends to confer upon all +-- recipients unlimited rights equal to those held by the Government. +-- These rights include rights to use, duplicate, release or disclose the +-- released technical data and computer software in whole or in part, in +-- any manner and for any purpose whatsoever, and to have or permit others +-- to do so. +-- +-- DISCLAIMER +-- +-- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR +-- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED +-- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE +-- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE +-- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A +-- PARTICULAR PURPOSE OF SAID MATERIAL. +--* +-- CHECK THAT THE DEFAULT EXPRESSIONS OF THE PARAMETERS OF A FORMAL +-- SUBPROGRAM ARE USED INSTEAD OF THE DEFAULTS (IF ANY) OF THE +-- ACTUAL SUBPROGRAM PARAMETER. + +-- HISTORY: +-- RJW 06/05/86 CREATED ORIGINAL TEST. +-- VCL 08/18/87 CHANGED A COUPLE OF STATIC DEFAULT EXPRESSIONS FOR +-- FORMAL SUBPROGRAM PARAMETERS TO DYNAMIC +-- EXPRESSIONS VIA THE USE OF THE IDENTITY FUNCTION. +-- EDWARD V. BERARD 08/13/90 +-- ADDED CHECKS FOR MULTI-DIMENSIONAL ARRAYS. + +WITH REPORT ; + +PROCEDURE CC1311A IS + + TYPE NUMBERS IS (ZERO, ONE ,TWO); + + SHORT_START : CONSTANT := -100 ; + SHORT_END : CONSTANT := 100 ; + TYPE SHORT_RANGE IS RANGE SHORT_START .. SHORT_END ; + + SUBTYPE REALLY_SHORT IS SHORT_RANGE RANGE -9 .. 0 ; + + TYPE MONTH_TYPE IS (JAN, FEB, MAR, APR, MAY, JUN, JUL, AUG, + SEP, OCT, NOV, DEC) ; + + SUBTYPE FIRST_HALF IS MONTH_TYPE RANGE JAN .. JUN ; + + TYPE DAY_TYPE IS RANGE 1 .. 31 ; + TYPE YEAR_TYPE IS RANGE 1904 .. 2050 ; + TYPE DATE IS RECORD + MONTH : MONTH_TYPE ; + DAY : DAY_TYPE ; + YEAR : YEAR_TYPE ; + END RECORD ; + + TODAY : DATE := (MONTH => AUG, + DAY => 8, + YEAR => 1990) ; + + FIRST_DATE : DATE := (DAY => 6, + MONTH => JUN, + YEAR => 1967) ; + + SUBTYPE FIRST_FIVE IS CHARACTER RANGE 'A' .. 'E' ; + + TYPE THREE_DIMENSIONAL IS ARRAY (REALLY_SHORT, + FIRST_HALF, + FIRST_FIVE) OF DATE ; + + GENERIC + + TYPE FIRST_INDEX IS (<>) ; + TYPE SECOND_INDEX IS (<>) ; + TYPE THIRD_INDEX IS (<>) ; + TYPE COMPONENT_TYPE IS PRIVATE ; + DEFAULT_VALUE : IN COMPONENT_TYPE ; + TYPE CUBE IS ARRAY (FIRST_INDEX, + SECOND_INDEX, + THIRD_INDEX) OF COMPONENT_TYPE ; + WITH FUNCTION FUN (FIRST : IN CUBE := (CUBE'RANGE => + (CUBE'RANGE (2) => + (CUBE'RANGE (3) => + DEFAULT_VALUE)))) + RETURN CUBE ; + + PROCEDURE PROC_WITH_3D_FUNC ; + + PROCEDURE PROC_WITH_3D_FUNC IS + + BEGIN -- PROC_WITH_3D_FUNC + + IF FUN /= CUBE'(CUBE'RANGE => + (CUBE'RANGE (2) => + (CUBE'RANGE (3) => DEFAULT_VALUE))) THEN + REPORT.FAILED ("PROBLEMS WITH THREE DIMENSIONAL " & + "ARRAY, FUNCTION, AND PROCEDURE.") ; + END IF ; + + END PROC_WITH_3D_FUNC ; + + GENERIC + + TYPE FIRST_INDEX IS (<>) ; + TYPE SECOND_INDEX IS (<>) ; + TYPE THIRD_INDEX IS (<>) ; + TYPE COMPONENT_TYPE IS PRIVATE ; + DEFAULT_VALUE : IN COMPONENT_TYPE ; + TYPE CUBE IS ARRAY (FIRST_INDEX, + SECOND_INDEX, + THIRD_INDEX) OF COMPONENT_TYPE ; + WITH FUNCTION FUN (FIRST : IN CUBE := (CUBE'RANGE => + (CUBE'RANGE (2) => + (CUBE'RANGE (3) => + DEFAULT_VALUE)))) + RETURN CUBE ; + + PACKAGE PKG_WITH_3D_FUNC IS + END PKG_WITH_3D_FUNC ; + + PACKAGE BODY PKG_WITH_3D_FUNC IS + BEGIN -- PKG_WITH_3D_FUNC + + REPORT.TEST("CC1311A","CHECK THAT THE DEFAULT EXPRESSIONS " & + "OF THE PARAMETERS OF A FORMAL SUBPROGRAM ARE " & + "USED INSTEAD OF THE DEFAULTS (IF ANY) OF THE " & + "ACTUAL SUBPROGRAM PARAMETER" ) ; + + IF FUN /= CUBE'(CUBE'RANGE => + (CUBE'RANGE (2) => + (CUBE'RANGE (3) => DEFAULT_VALUE))) THEN + REPORT.FAILED ("PROBLEMS WITH THREE DIMENSIONAL " & + "ARRAY, FUNCTION, AND PACKAGE.") ; + END IF ; + + END PKG_WITH_3D_FUNC ; + + GENERIC + + TYPE FIRST_INDEX IS (<>) ; + TYPE SECOND_INDEX IS (<>) ; + TYPE THIRD_INDEX IS (<>) ; + TYPE COMPONENT_TYPE IS PRIVATE ; + DEFAULT_VALUE : IN COMPONENT_TYPE ; + TYPE CUBE IS ARRAY (FIRST_INDEX, + SECOND_INDEX, + THIRD_INDEX) OF COMPONENT_TYPE ; + WITH FUNCTION FUN (FIRST : IN CUBE := (CUBE'RANGE => + (CUBE'RANGE (2) => + (CUBE'RANGE (3) => + DEFAULT_VALUE)))) + RETURN CUBE ; + + FUNCTION FUNC_WITH_3D_FUNC RETURN BOOLEAN ; + + FUNCTION FUNC_WITH_3D_FUNC RETURN BOOLEAN IS + BEGIN -- FUNC_WITH_3D_FUNC + + RETURN FUN = CUBE'(CUBE'RANGE => + (CUBE'RANGE (2) => + (CUBE'RANGE (3) => DEFAULT_VALUE))) ; + + END FUNC_WITH_3D_FUNC ; + + GENERIC + + TYPE FIRST_INDEX IS (<>) ; + TYPE SECOND_INDEX IS (<>) ; + TYPE THIRD_INDEX IS (<>) ; + TYPE COMPONENT_TYPE IS PRIVATE ; + DEFAULT_VALUE : IN COMPONENT_TYPE ; + TYPE CUBE IS ARRAY (FIRST_INDEX, + SECOND_INDEX, + THIRD_INDEX) OF COMPONENT_TYPE ; + WITH PROCEDURE PROC (INPUT : IN CUBE := (CUBE'RANGE => + (CUBE'RANGE (2) => + (CUBE'RANGE (3) => + DEFAULT_VALUE))) ; + OUTPUT : OUT CUBE) ; + + PROCEDURE PROC_WITH_3D_PROC ; + + PROCEDURE PROC_WITH_3D_PROC IS + + RESULTS : CUBE ; + + BEGIN -- PROC_WITH_3D_PROC + + PROC (OUTPUT => RESULTS) ; + + IF RESULTS /= CUBE'(CUBE'RANGE => + (CUBE'RANGE (2) => + (CUBE'RANGE (3) => DEFAULT_VALUE))) THEN + REPORT.FAILED ("PROBLEMS WITH THREE DIMENSIONAL " & + "ARRAY, PROCEDURE, AND PROCEDURE.") ; + END IF ; + + END PROC_WITH_3D_PROC ; + + GENERIC + + TYPE FIRST_INDEX IS (<>) ; + TYPE SECOND_INDEX IS (<>) ; + TYPE THIRD_INDEX IS (<>) ; + TYPE COMPONENT_TYPE IS PRIVATE ; + DEFAULT_VALUE : IN COMPONENT_TYPE ; + TYPE CUBE IS ARRAY (FIRST_INDEX, + SECOND_INDEX, + THIRD_INDEX) OF COMPONENT_TYPE ; + WITH PROCEDURE PROC (INPUT : IN CUBE := (CUBE'RANGE => + (CUBE'RANGE (2) => + (CUBE'RANGE (3) => + DEFAULT_VALUE))) ; + OUTPUT : OUT CUBE) ; + + PACKAGE PKG_WITH_3D_PROC IS + END PKG_WITH_3D_PROC ; + + PACKAGE BODY PKG_WITH_3D_PROC IS + + RESULTS : CUBE ; + + BEGIN -- PKG_WITH_3D_PROC + + PROC (OUTPUT => RESULTS) ; + + IF RESULTS /= CUBE'(CUBE'RANGE => + (CUBE'RANGE (2) => + (CUBE'RANGE (3) => DEFAULT_VALUE))) THEN + REPORT.FAILED ("PROBLEMS WITH THREE DIMENSIONAL " & + "ARRAY, PROCEDURE, AND PACKAGE.") ; + END IF ; + + END PKG_WITH_3D_PROC ; + + GENERIC + + TYPE FIRST_INDEX IS (<>) ; + TYPE SECOND_INDEX IS (<>) ; + TYPE THIRD_INDEX IS (<>) ; + TYPE COMPONENT_TYPE IS PRIVATE ; + DEFAULT_VALUE : IN COMPONENT_TYPE ; + TYPE CUBE IS ARRAY (FIRST_INDEX, + SECOND_INDEX, + THIRD_INDEX) OF COMPONENT_TYPE ; + WITH PROCEDURE PROC (INPUT : IN CUBE := (CUBE'RANGE => + (CUBE'RANGE (2) => + (CUBE'RANGE (3) => + DEFAULT_VALUE))) ; + OUTPUT : OUT CUBE) ; + + FUNCTION FUNC_WITH_3D_PROC RETURN BOOLEAN ; + + FUNCTION FUNC_WITH_3D_PROC RETURN BOOLEAN IS + + RESULTS : CUBE ; + + BEGIN -- FUNC_WITH_3D_PROC + + PROC (OUTPUT => RESULTS) ; + RETURN RESULTS = CUBE'(CUBE'RANGE => + (CUBE'RANGE (2) => + (CUBE'RANGE (3) => DEFAULT_VALUE))) ; + + END FUNC_WITH_3D_PROC ; + + GENERIC + TYPE T IS (<>); + WITH FUNCTION F (X : T := T'VAL (0)) RETURN T; + FUNCTION FUNC1 RETURN BOOLEAN; + + FUNCTION FUNC1 RETURN BOOLEAN IS + BEGIN -- FUNC1 + RETURN F = T'VAL (0); + END FUNC1; + + GENERIC + TYPE T IS (<>); + WITH FUNCTION F (X : T := T'VAL (REPORT.IDENT_INT(0))) + RETURN T; + PACKAGE PKG1 IS END PKG1; + + PACKAGE BODY PKG1 IS + BEGIN -- PKG1 + IF F /= T'VAL (0) THEN + REPORT.FAILED ("INCORRECT DEFAULT VALUE WITH " & + "FUNCTION 'F' AND PACKAGE 'PKG1'" ); + END IF; + END PKG1; + GENERIC + TYPE T IS (<>); + WITH FUNCTION F (X : T := T'VAL (0)) RETURN T; + PROCEDURE PROC1; + + PROCEDURE PROC1 IS + BEGIN -- PROC1 + IF F /= T'VAL (0) THEN + REPORT.FAILED ("INCORRECT DEFAULT VALUE WITH " & + "FUNCTION 'F' AND PROCEDURE 'PROC1'" ); + END IF; + END PROC1; + + GENERIC + TYPE T IS (<>); + WITH PROCEDURE P (RESULTS : OUT T ; + X : T := T'VAL (0)) ; + FUNCTION FUNC2 RETURN BOOLEAN; + + FUNCTION FUNC2 RETURN BOOLEAN IS + RESULTS : T; + BEGIN -- FUNC2 + P (RESULTS); + RETURN RESULTS = T'VAL (0); + END FUNC2; + + GENERIC + TYPE T IS (<>); + WITH PROCEDURE P (RESULTS : OUT T; + X : T := T'VAL(REPORT.IDENT_INT(0))); + PACKAGE PKG2 IS END PKG2 ; + + PACKAGE BODY PKG2 IS + RESULTS : T; + BEGIN -- PKG2 + P (RESULTS); + IF RESULTS /= T'VAL (0) THEN + REPORT.FAILED ("INCORRECT DEFAULT VALUE WITH " & + "PROCEDURE 'P' AND PACKAGE 'PKG2'" ); + END IF; + END PKG2; + + GENERIC + TYPE T IS (<>); + WITH PROCEDURE P (RESULTS :OUT T; X : T := T'VAL (0)); + PROCEDURE PROC2; + + PROCEDURE PROC2 IS + RESULTS : T; + BEGIN -- PROC2 + P (RESULTS); + IF RESULTS /= T'VAL (0) THEN + REPORT.FAILED ("INCORRECT DEFAULT VALUE WITH " & + "PROCEDURE 'P' AND PROCEDURE 'PROC2'" ); + END IF; + END PROC2; + + FUNCTION F1 (A : NUMBERS := ONE) RETURN NUMBERS IS + BEGIN -- F1 + RETURN A; + END; + + PROCEDURE P2 (OUTVAR : OUT NUMBERS; INVAR : NUMBERS := TWO) IS + BEGIN -- P2 + OUTVAR := INVAR; + END; + + FUNCTION TD_FUNC (FIRST : IN THREE_DIMENSIONAL := + (THREE_DIMENSIONAL'RANGE => + (THREE_DIMENSIONAL'RANGE (2) => + (THREE_DIMENSIONAL'RANGE (3) => + FIRST_DATE)))) + RETURN THREE_DIMENSIONAL IS + + BEGIN -- TD_FUNC + + RETURN FIRST ; + + END TD_FUNC ; + + PROCEDURE TD_PROC (INPUT : IN THREE_DIMENSIONAL := + (THREE_DIMENSIONAL'RANGE => + (THREE_DIMENSIONAL'RANGE (2) => + (THREE_DIMENSIONAL'RANGE (3) => + FIRST_DATE))) ; + OUTPUT : OUT THREE_DIMENSIONAL) IS + BEGIN -- TD_PROC + + OUTPUT := INPUT ; + + END TD_PROC ; + + PROCEDURE NEW_PROC_WITH_3D_FUNC IS NEW + PROC_WITH_3D_FUNC (FIRST_INDEX => REALLY_SHORT, + SECOND_INDEX => FIRST_HALF, + THIRD_INDEX => FIRST_FIVE, + COMPONENT_TYPE => DATE, + DEFAULT_VALUE => TODAY, + CUBE => THREE_DIMENSIONAL, + FUN => TD_FUNC) ; + + PACKAGE NEW_PKG_WITH_3D_FUNC IS NEW + PKG_WITH_3D_FUNC (FIRST_INDEX => REALLY_SHORT, + SECOND_INDEX => FIRST_HALF, + THIRD_INDEX => FIRST_FIVE, + COMPONENT_TYPE => DATE, + DEFAULT_VALUE => TODAY, + CUBE => THREE_DIMENSIONAL, + FUN => TD_FUNC) ; + + FUNCTION NEW_FUNC_WITH_3D_FUNC IS NEW + FUNC_WITH_3D_FUNC (FIRST_INDEX => REALLY_SHORT, + SECOND_INDEX => FIRST_HALF, + THIRD_INDEX => FIRST_FIVE, + COMPONENT_TYPE => DATE, + DEFAULT_VALUE => TODAY, + CUBE => THREE_DIMENSIONAL, + FUN => TD_FUNC) ; + + PROCEDURE NEW_PROC_WITH_3D_PROC IS NEW + PROC_WITH_3D_PROC (FIRST_INDEX => REALLY_SHORT, + SECOND_INDEX => FIRST_HALF, + THIRD_INDEX => FIRST_FIVE, + COMPONENT_TYPE => DATE, + DEFAULT_VALUE => TODAY, + CUBE => THREE_DIMENSIONAL, + PROC => TD_PROC) ; + + PACKAGE NEW_PKG_WITH_3D_PROC IS NEW + PKG_WITH_3D_PROC (FIRST_INDEX => REALLY_SHORT, + SECOND_INDEX => FIRST_HALF, + THIRD_INDEX => FIRST_FIVE, + COMPONENT_TYPE => DATE, + DEFAULT_VALUE => TODAY, + CUBE => THREE_DIMENSIONAL, + PROC => TD_PROC) ; + + FUNCTION NEW_FUNC_WITH_3D_PROC IS NEW + FUNC_WITH_3D_PROC (FIRST_INDEX => REALLY_SHORT, + SECOND_INDEX => FIRST_HALF, + THIRD_INDEX => FIRST_FIVE, + COMPONENT_TYPE => DATE, + DEFAULT_VALUE => TODAY, + CUBE => THREE_DIMENSIONAL, + PROC => TD_PROC) ; + + FUNCTION NFUNC1 IS NEW FUNC1 (NUMBERS, F1); + PACKAGE NPKG1 IS NEW PKG1 (NUMBERS, F1); + PROCEDURE NPROC1 IS NEW PROC1 (NUMBERS, F1); + + FUNCTION NFUNC2 IS NEW FUNC2 (NUMBERS, P2); + PACKAGE NPKG2 IS NEW PKG2 (NUMBERS, P2); + PROCEDURE NPROC2 IS NEW PROC2 (NUMBERS, P2); + +BEGIN -- CC1311A + + IF NOT NFUNC1 THEN + REPORT.FAILED ("INCORRECT DEFAULT VALUE " & + "WITH FUNCTION 'NFUNC1'" ) ; + END IF ; + + IF NOT NFUNC2 THEN + REPORT.FAILED ("INCORRECT DEFAULT VALUE " & + "WITH FUNCTION 'NFUNC2'" ) ; + END IF ; + + NPROC1 ; + NPROC2 ; + + NEW_PROC_WITH_3D_FUNC ; + + IF NOT NEW_FUNC_WITH_3D_FUNC THEN + REPORT.FAILED ("PROBLEMS WITH THREE DIMENSIONAL ARRAY, " & + "FUNCTION, AND FUNCTION.") ; + END IF ; + + NEW_PROC_WITH_3D_PROC ; + + IF NOT NEW_FUNC_WITH_3D_PROC THEN + REPORT.FAILED ("PROBLEMS WITH THREE DIMENSIONAL ARRAY, " & + "FUNCTION, AND PROCEDURE.") ; + END IF ; + + REPORT.RESULT ; + +END CC1311A ; diff --git a/gcc/testsuite/ada/acats/tests/cc/cc1311b.ada b/gcc/testsuite/ada/acats/tests/cc/cc1311b.ada new file mode 100644 index 000000000..eb30726b8 --- /dev/null +++ b/gcc/testsuite/ada/acats/tests/cc/cc1311b.ada @@ -0,0 +1,332 @@ +-- CC1311B.ADA + +-- Grant of Unlimited Rights +-- +-- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687, +-- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained +-- unlimited rights in the software and documentation contained herein. +-- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making +-- this public release, the Government intends to confer upon all +-- recipients unlimited rights equal to those held by the Government. +-- These rights include rights to use, duplicate, release or disclose the +-- released technical data and computer software in whole or in part, in +-- any manner and for any purpose whatsoever, and to have or permit others +-- to do so. +-- +-- DISCLAIMER +-- +-- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR +-- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED +-- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF 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 PARAMETERS OF DEFAULT AND FORMAL SUBPROGRAMS HAVE +-- THE SAME TYPE BUT NOT THE SAME SUBTYPE, THE PARAMETER SUBTYPES OF +-- THE SUBPROGRAM DENOTED BY THE DEFAULT ARE USED INSTEAD OF +-- SUBTYPES SPECIFIED IN THE FORMAL SUBPROGRAM DECLARATION. + +-- HISTORY: +-- RJW 06/11/86 CREATED ORIGINAL TEST. +-- DHH 10/20/86 CORRECTED RANGE ERRORS. +-- PWN 01/31/95 REMOVED INCONSISTENCIES WITH ADA 9X. +-- PWN 10/27/95 REMOVED CHECKS AGAINST ARRAY SLIDING RULES THAT +-- HAVE BEEN RELAXED. +-- PWN 10/25/96 RESTORED CHECKS WITH NEW ADA 95 EXPECTED RESULTS. + +WITH REPORT; USE REPORT; + +PROCEDURE CC1311B IS + +BEGIN + TEST ("CC1311B", "CHECK THAT IF PARAMETERS OF DEFAULT AND " & + "FORMAL SUBPROGRAMS HAVE THE SAME TYPE BUT " & + "NOT THE SAME SUBTYPE, THE PARAMETER SUBTYPES " & + "OF THE SUBPROGRAM DENOTED BY THE DEFAULT ARE " & + "USED INSTEAD OF SUBTYPES SPECIFIED IN THE " & + "FORMAL SUBPROGRAM DECLARATION" ); + + DECLARE + TYPE NUMBERS IS (ZERO, ONE ,TWO); + SUBTYPE ZERO_TWO IS NUMBERS; + SUBTYPE ZERO_ONE IS NUMBERS RANGE ZERO .. ONE; + + FUNCTION FSUB (X : ZERO_ONE) RETURN ZERO_ONE IS + BEGIN + RETURN NUMBERS'VAL (IDENT_INT (NUMBERS'POS (ONE))); + END FSUB; + + GENERIC + WITH FUNCTION F (X : ZERO_TWO := TWO) RETURN ZERO_TWO + IS FSUB; + FUNCTION FUNC RETURN ZERO_TWO; + + FUNCTION FUNC RETURN ZERO_TWO IS + BEGIN + RETURN F; + EXCEPTION + WHEN CONSTRAINT_ERROR => + RETURN ZERO; + WHEN OTHERS => + FAILED ( "WRONG EXCEPTION RAISED WITH " & + "NFUNC1" ); + RETURN ZERO; + END FUNC; + + FUNCTION NFUNC1 IS NEW FUNC; + + BEGIN + IF NFUNC1 = ONE THEN + FAILED ( "NO EXCEPTION RAISED WITH NFUNC1" ); + END IF; + END; + + DECLARE + TYPE GENDER IS (MALE, FEMALE); + + TYPE PERSON (SEX : GENDER) IS + RECORD + CASE SEX IS + WHEN MALE => + BEARDED : BOOLEAN; + WHEN FEMALE => + CHILDREN : INTEGER; + END CASE; + END RECORD; + + SUBTYPE MAN IS PERSON (SEX => MALE); + SUBTYPE TESTWRITER IS PERSON (FEMALE); + + ROSA : TESTWRITER := (FEMALE, 4); + + FUNCTION F (X : MAN) RETURN PERSON IS + TOM : PERSON (MALE) := (MALE, FALSE); + BEGIN + IF EQUAL (3, 3) THEN + RETURN X; + ELSE + RETURN TOM; + END IF; + END F; + + GENERIC + TYPE T IS PRIVATE; + X1 : T; + WITH FUNCTION F (X : T) RETURN T IS <> ; + PACKAGE PKG IS END PKG; + + PACKAGE BODY PKG IS + BEGIN + IF F(X1) = X1 THEN + FAILED ( "NO EXCEPTION RAISED WITH " & + "FUNCTION 'F' AND PACKAGE " & + "'PKG' - 1" ); + ELSE + FAILED ( "NO EXCEPTION RAISED WITH " & + "FUNCTION 'F' AND PACKAGE " & + "'PKG' - 2" ); + END IF; + EXCEPTION + WHEN CONSTRAINT_ERROR => + NULL; + WHEN OTHERS => + FAILED ( "WRONG EXCEPTION RAISED WITH " & + "FUNCTION 'F' AND PACKAGE 'PKG'" ); + END PKG; + + PACKAGE NPKG IS NEW PKG (TESTWRITER, ROSA); + + BEGIN + COMMENT ( "PACKAGE BODY ELABORATED - 1" ); + END; + + DECLARE + TYPE VECTOR IS ARRAY (POSITIVE RANGE <>) OF INTEGER; + SUBTYPE SUBV1 IS VECTOR (1 .. 5); + SUBTYPE SUBV2 IS VECTOR (2 .. 6); + + V1 : SUBV1 := (1, 2, 3, 4, 5); + + FUNCTION FSUB (Y : SUBV2) RETURN VECTOR IS + Z : SUBV2; + BEGIN + FOR I IN Y'RANGE LOOP + Z (I) := IDENT_INT (Y (I)); + END LOOP; + RETURN Z; + END; + + GENERIC + WITH FUNCTION F (X : SUBV1 := V1) RETURN SUBV1 IS FSUB; + PROCEDURE PROC; + + PROCEDURE PROC IS + BEGIN + IF F = V1 THEN + COMMENT ( "NO EXCEPTION RAISED WITH " & + "FUNCTION 'F' AND PROCEDURE " & + "'PROC' - 1" ); + ELSE + COMMENT ( "NO EXCEPTION RAISED WITH " & + "FUNCTION 'F' AND PROCEDURE " & + "'PROC' - 2" ); + END IF; + EXCEPTION + WHEN CONSTRAINT_ERROR => + FAILED ( "CONSTRAINT_ERROR RAISED WITH " & + "FUNCTION 'F' AND PROCEDURE " & + "'PROC'" ); + WHEN OTHERS => + FAILED ( "WRONG EXCEPTION RAISED WITH " & + "FUNCTION 'F' AND PROCEDURE " & + "'PROC'" ); + END PROC; + + PROCEDURE NPROC IS NEW PROC; + BEGIN + NPROC; + END; + + DECLARE + + TYPE ACC IS ACCESS STRING; + + SUBTYPE INDEX1 IS INTEGER RANGE 1 .. 5; + SUBTYPE INDEX2 IS INTEGER RANGE 2 .. 6; + + SUBTYPE ACC1 IS ACC (INDEX1); + SUBTYPE ACC2 IS ACC (INDEX2); + + AC2 : ACC2 := NEW STRING'(2 .. 6 => 'A'); + AC : ACC; + + PROCEDURE P (RESULTS : OUT ACC1; X : ACC1) IS + BEGIN + RESULTS := NULL; + END P; + + GENERIC + WITH PROCEDURE P1 (RESULTS : OUT ACC2; X : ACC2 := AC2) + IS P; + FUNCTION FUNC RETURN ACC; + + FUNCTION FUNC RETURN ACC IS + RESULTS : ACC; + BEGIN + P1 (RESULTS); + RETURN RESULTS; + EXCEPTION + WHEN CONSTRAINT_ERROR => + RETURN NEW STRING'("ABCDE"); + WHEN OTHERS => + FAILED ( "WRONG EXCEPTION RAISED WITH " & + "NFUNC2" ); + RETURN NULL; + END FUNC; + + FUNCTION NFUNC2 IS NEW FUNC; + + BEGIN + AC := NFUNC2; + IF AC = NULL OR ELSE AC.ALL /= "ABCDE" THEN + FAILED ( "NO OR WRONG EXCEPTION RAISED WITH NFUNC2" ); + END IF; + END; + + DECLARE + SUBTYPE FLOAT1 IS FLOAT RANGE -1.0 .. 0.0; + SUBTYPE FLOAT2 IS FLOAT RANGE 0.0 .. 1.0; + + PROCEDURE PSUB (RESULTS : OUT FLOAT2; X : FLOAT2) IS + BEGIN + IF EQUAL (3, 3) THEN + RESULTS := X; + ELSE + RESULTS := 0.0; + END IF; + END PSUB; + + GENERIC + WITH PROCEDURE P (RESULTS : OUT FLOAT1; + X : FLOAT1 := -0.0625) IS PSUB; + PACKAGE PKG IS END PKG; + + PACKAGE BODY PKG IS + RESULTS : FLOAT1; + BEGIN + P (RESULTS); + IF RESULTS = 1.0 THEN + FAILED ( "NO EXCEPTION RAISED WITH " & + "PROCEDURE 'P' AND PACKAGE " & + "'PKG' - 1" ); + ELSE + FAILED ( "NO EXCEPTION RAISED WITH " & + "PROCEDURE 'P' AND PACKAGE " & + "'PKG' - 2" ); + END IF; + EXCEPTION + WHEN CONSTRAINT_ERROR => + NULL; + WHEN OTHERS => + FAILED ( "WRONG EXCEPTION RAISED WITH " & + "PROCEDURE 'P' AND PACKAGE 'PKG'" ); + END PKG; + + PACKAGE NPKG IS NEW PKG; + BEGIN + COMMENT ( "PACKAGE BODY ELABORATED - 2" ); + END; + + DECLARE + TYPE FIXED IS DELTA 0.125 RANGE -1.0 .. 1.0; + SUBTYPE FIXED1 IS FIXED RANGE -0.5 .. 0.0; + SUBTYPE FIXED2 IS FIXED RANGE 0.0 .. 0.5; + + PROCEDURE P (RESULTS : OUT FIXED1; X : FIXED1) IS + BEGIN + IF EQUAL (3, 3) THEN + RESULTS := X; + ELSE + RESULTS := X; + END IF; + END P; + + GENERIC + TYPE F IS DELTA <>; + F1 : F; + WITH PROCEDURE P (RESULTS : OUT F; X : F) IS <> ; + PROCEDURE PROC; + + PROCEDURE PROC IS + RESULTS : F; + BEGIN + P (RESULTS, F1); + IF RESULTS = 0.0 THEN + FAILED ( "NO EXCEPTION RAISED WITH " & + "PROCEDURE 'P' AND PROCEDURE " & + "'PROC' - 1" ); + ELSE + FAILED ( "NO EXCEPTION RAISED WITH " & + "PROCEDURE 'P' AND PROCEDURE " & + "'PROC' - 2" ); + END IF; + EXCEPTION + WHEN CONSTRAINT_ERROR => + NULL; + WHEN OTHERS => + FAILED ( "WRONG EXCEPTION RAISED WITH " & + "PROCEDURE 'P' AND PROCEDURE " & + "'PROC'" ); + END PROC; + + PROCEDURE NPROC IS NEW PROC (FIXED2, 0.125); + + BEGIN + NPROC; + END; + + RESULT; + +END CC1311B; diff --git a/gcc/testsuite/ada/acats/tests/cc/cc2002a.ada b/gcc/testsuite/ada/acats/tests/cc/cc2002a.ada new file mode 100644 index 000000000..95b9e91ef --- /dev/null +++ b/gcc/testsuite/ada/acats/tests/cc/cc2002a.ada @@ -0,0 +1,77 @@ +-- CC2002A.ADA + +-- Grant of Unlimited Rights +-- +-- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687, +-- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained +-- unlimited rights in the software and documentation contained herein. +-- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making +-- this public release, the Government intends to confer upon all +-- recipients unlimited rights equal to those held by the Government. +-- These rights include rights to use, duplicate, release or disclose the +-- released technical data and computer software in whole or in part, in +-- any manner and for any purpose whatsoever, and to have or permit others +-- to do so. +-- +-- DISCLAIMER +-- +-- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR +-- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED +-- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF 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 ELABORATION OF A GENERIC BODY HAS NO EFFECT OTHER +-- THAN TO ESTABLISH THE TEMPLATE BODY TO BE USED FOR THE +-- CORRESPONDING INSTANTIATIONS. + +-- ASL 09/02/81 +-- EG 10/30/85 ELIMINATE THE USE OF NUMERIC_ERROR IN TEST. +-- PWN 01/31/95 REMOVED INCONSISTENCIES WITH ADA 9X. + +WITH REPORT; USE REPORT; +PROCEDURE CC2002A IS + + GLOBAL : INTEGER := 0; + Q : INTEGER RANGE 1..1 := 1; +BEGIN + TEST ("CC2002A","NO SIDE EFFECTS OF ELABORATION OF GENERIC BODY"); + + BEGIN + DECLARE + GENERIC + PACKAGE P IS + END P; + + GENERIC PROCEDURE PROC; + + PROCEDURE PROC IS + C : CONSTANT INTEGER RANGE 1 .. 1 := 2; + BEGIN + RAISE PROGRAM_ERROR; + END PROC; + + PACKAGE BODY P IS + C : CONSTANT BOOLEAN := + BOOLEAN'SUCC(IDENT_BOOL(TRUE)); + BEGIN + GLOBAL := 1; + Q := Q + 1; + END P; + BEGIN + NULL; + END; + EXCEPTION + WHEN OTHERS => + FAILED ("EXCEPTION RAISED DURING ELABORATION OF " & + "GENERIC BODY"); + END; + + IF GLOBAL /= 0 THEN + FAILED ("VALUE OF GLOBAL VARIABLE CHANGED BY ELABORATION " & + "OF GENERIC BODY"); + END IF; + + RESULT; +END CC2002A; diff --git a/gcc/testsuite/ada/acats/tests/cc/cc30001.a b/gcc/testsuite/ada/acats/tests/cc/cc30001.a new file mode 100644 index 000000000..69010e421 --- /dev/null +++ b/gcc/testsuite/ada/acats/tests/cc/cc30001.a @@ -0,0 +1,219 @@ +-- CC30001.A +-- +-- Grant of Unlimited Rights +-- +-- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687, +-- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained +-- unlimited rights in the software and documentation contained herein. +-- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making +-- this public release, the Government intends to confer upon all +-- recipients unlimited rights equal to those held by the Government. +-- These rights include rights to use, duplicate, release or disclose the +-- released technical data and computer software in whole or in part, in +-- any manner and for any purpose whatsoever, and to have or permit others +-- to do so. +-- +-- DISCLAIMER +-- +-- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR +-- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED +-- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE +-- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE +-- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A +-- PARTICULAR PURPOSE OF SAID MATERIAL. +--* +-- +-- OBJECTIVE: +-- Check that if a non-overriding primitive subprogram is declared for +-- a type derived from a formal derived tagged type, the copy of that +-- subprogram in an instance can override a subprogram inherited from the +-- actual type. +-- +-- TEST DESCRIPTION: +-- User writes program to handle both mail messages and system messages. +-- +-- Mail messages are created by instantiating a generic "mail" package +-- with a root message type. System messages are created by +-- instantiating the generic with a system message type derived from the +-- root in a separate package. The system message type has a primitive +-- subprogram called Send. +-- +-- Inside the generic, a "mail" type is derived from the generic formal +-- derived type, and a "Send" operation is declared. +-- +-- Declare a root tagged type T. Declare a generic package with a formal +-- derived type using the root tagged type as ancestor. In the generic, +-- derive a type from the formal derived type and declare a primitive +-- subprogram for it. In a separate package, declare a derivative DT of +-- the root tagged type T and declare a primitive subprogram which is +-- type conformant with (and hence, overridable for) the primitive +-- declared in the generic. Instantiate the generic for DT. Make both +-- dispatching and non-dispatching calls to the primitive subprogram. In +-- both cases the version of the subprogram in the instance should be +-- called (since it overrides the implementation inherited from the +-- actual). +-- +-- +-- CHANGE HISTORY: +-- 06 Dec 94 SAIC ACVC 2.0 +-- 13 Apr 95 SAIC Replaced call involving instance for root tagged +-- type with a dispatching call involving instance +-- for derived type. Updated commentary. Moved +-- instantiations (and related commentary) to +-- library-level to avoid accessibility violation. +-- Commented out instantiation for root tagged type. +-- 27 Feb 97 PWB.CTA Added elaboration pragma. +--! + +package CC30001_0 is -- Root message type. + + type Msg_Type is tagged record + Text : String (1 .. 20); + Message_Sent : Boolean; + end record; + +end CC30001_0; + + + --==================================================================-- + + +with CC30001_0; -- Root message type. +generic -- Generic "mail" package. + type Message is new CC30001_0.Msg_Type with private; +package CC30001_1 is + + type Mail_Type is new Message with record -- Derived from formal type. + To : String (1 .. 8); + end record; + + procedure Send (M : in out Mail_Type); -- For this test, this version + -- of Send should be called in + -- ... Other operations. -- all cases. + +end CC30001_1; + + + --==================================================================-- + + +package body CC30001_1 is + + procedure Send (M : in out Mail_Type) is + begin + -- ... Code to send message omitted for brevity. + M.Message_Sent := True; + end Send; + +end CC30001_1; + + + --==================================================================-- + + +with CC30001_0; -- Root message type. +package CC30001_2 is -- System message type and operations. + + type Signal_Type is (Note, Warning, Error); + + type Sys_Message is new CC30001_0.Msg_Type with record -- Derived from + Signal : Signal_Type := Warning; -- root type. + end record; + + procedure Send (Item : in out Sys_Message); -- For this test, this version + -- of Send should never be + -- ... Other operations. -- called (it will have been + -- overridden). +end CC30001_2; + + + --==================================================================-- + + +package body CC30001_2 is + + procedure Send (Item : in out Sys_Message) is + begin + -- ... Code to send message omitted for brevity. + Item.Message_Sent := False; -- Ensure this procedure gives a different + end Send; -- result than CC30001_1.Send. + +end CC30001_2; + + + --==================================================================-- + + +-- User first sets up support for mail messages by instantiating the +-- generic mail package for the root message type. An operation "Send" is +-- declared for the mail message type in the instance. +-- +-- with CC30001_0; -- Root message type. +-- with CC30001_1; -- Generic "mail" package. +-- package Mail_Messages is new CC30001_1 (CC30001_0.Msg_Type); + + + --==================================================================-- + + +-- Next, the user sets up support for system messages by instantiating the +-- generic mail package with the system message type. An operation "Send" +-- is declared for the "system" mail message type in the instance. This +-- operation overrides the "Send" operation inherited from the system +-- message type actual (a situation the user may not have intended). + +with CC30001_1; -- Generic "mail" package. +with CC30001_2; -- System message type and operations. +pragma Elaborate (CC30001_1); +package CC30001_3 is new CC30001_1 (CC30001_2.Sys_Message); + + + --==================================================================-- + +with CC30001_2; -- System message type and operations. +with CC30001_3; -- Instance with mail type and operations. + +with Report; +procedure CC30001 is + + package System_Messages renames CC30001_3; + + + Sys_Msg1 : System_Messages.Mail_Type := (Text => "System shutting down", + Signal => CC30001_2.Warning, + To => "AllUsers", + Message_Sent => False); + + Sys_Msg2 : System_Messages.Mail_Type'Class := Sys_Msg1; + + + use System_Messages, CC30001_2; -- All versions of "Send" + -- directly visible. + +begin + + Report.Test ("CC30001", "Check that if a non-overriding primitive " & + "subprogram is declared for a type derived from a formal " & + "derived tagged type, the copy of that subprogram in an " & + "instance can override a subprogram inherited from the " & + "actual type"); + + + Send (Sys_Msg1); -- Calls version declared in instance (version declared + -- in CC30001_2 has been overridden). + + if not Sys_Msg1.Message_Sent then + Report.Failed ("Non-dispatching call: instance operation not called"); + end if; + + + Send (Sys_Msg2); -- Calls version declared in instance (version declared + -- in CC30001_2 has been overridden). + + if not Sys_Msg2.Message_Sent then + Report.Failed ("Dispatching call: instance operation not called"); + end if; + + + Report.Result; +end CC30001; diff --git a/gcc/testsuite/ada/acats/tests/cc/cc30002.a b/gcc/testsuite/ada/acats/tests/cc/cc30002.a new file mode 100644 index 000000000..5132f8cae --- /dev/null +++ b/gcc/testsuite/ada/acats/tests/cc/cc30002.a @@ -0,0 +1,349 @@ +-- CC30002.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 an explicit declaration in the private part of an instance +-- does not override an implicit declaration in the instance, unless the +-- corresponding explicit declaration in the generic overrides a +-- corresponding implicit declaration in the generic. Check for primitive +-- subprograms of tagged types. +-- +-- TEST DESCRIPTION: +-- Consider the following: +-- +-- type Ancestor is tagged null record; +-- procedure R (X: in Ancestor); +-- +-- generic +-- type Formal is new Ancestor with private; +-- package G is +-- type T is new Formal with null record; +-- -- Implicit procedure R (X: in T); +-- procedure P (X: in T); -- (1) +-- private +-- procedure Q (X: in T); -- (2) +-- procedure R (X: in T); -- (3) Overrides implicit R in generic. +-- end G; +-- +-- type Actual is new Ancestor with null record; +-- procedure P (X: in Actual); +-- procedure Q (X: in Actual); +-- procedure R (X: in Actual); +-- +-- package Instance is new G (Formal => Actual); +-- +-- In the instance, the copy of P at (1) overrides Actual's P, since it +-- is declared in the visible part of the instance. The copy of Q at (2) +-- does not override anything. The copy of R at (3) overrides Actual's +-- R, even though it is declared in the private part, because within +-- the generic the explicit declaration of R overrides an implicit +-- declaration. +-- +-- Thus, for calls involving a parameter with tag T: +-- - Calls to P will execute the body declared for T. +-- - Calls to Q from within Instance will execute the body declared +-- for T. +-- - Calls to Q from outside Instance will execute the body declared +-- for Actual. +-- - Calls to R will execute the body declared for T. +-- +-- Verify this behavior for both dispatching and nondispatching calls to +-- Q and R. +-- +-- +-- CHANGE HISTORY: +-- 24 Feb 95 SAIC Initial prerelease version. +-- +--! + +package CC30002_0 is + + type TC_Body_Kind is (Body_Of_Ancestor, Body_In_Instance, + Body_Of_Actual, Initial_Value); + + type Camera is tagged record + -- ... Camera components. + TC_Focus_Called : TC_Body_Kind := Initial_Value; + TC_Shutter_Called : TC_Body_Kind := Initial_Value; + end record; + + procedure Focus (C: in out Camera); + + -- ...Other operations. + +end CC30002_0; + + + --==================================================================-- + + +package body CC30002_0 is + + procedure Focus (C: in out Camera) is + begin + -- Artificial for testing purposes. + C.TC_Focus_Called := Body_Of_Ancestor; + end Focus; + +end CC30002_0; + + + --==================================================================-- + + +with CC30002_0; +use CC30002_0; +generic + type Camera_Type is new CC30002_0.Camera with private; +package CC30002_1 is + + type Speed_Camera is new Camera_Type with record + Diag_Code: Positive; + -- ...Other components. + end record; + + -- Implicit procedure Focus (C: in out Speed_Camera) declared in generic. + procedure Self_Test_NonDisp (C: in out Speed_Camera); + procedure Self_Test_Disp (C: in out Speed_Camera'Class); + +private + + -- The following explicit declaration of Set_Shutter_Speed does NOT override + -- a corresponding implicit declaration in the generic. Therefore, its copy + -- does NOT override the implicit declaration (inherited from the actual) + -- in the instance. + + procedure Set_Shutter_Speed (C: in out Speed_Camera); + + -- The following explicit declaration of Focus DOES override a + -- corresponding implicit declaration (inherited from the parent) in the + -- generic. Therefore, its copy overrides the implicit declaration + -- (inherited from the actual) in the instance. + + procedure Focus (C: in out Speed_Camera); -- Overrides implicit Focus + -- in generic. +end CC30002_1; + + + --==================================================================-- + + +package body CC30002_1 is + + procedure Self_Test_NonDisp (C: in out Speed_Camera) is + begin + -- Nondispatching calls: + Focus (C); + Set_Shutter_Speed (C); + end Self_Test_NonDisp; + + procedure Self_Test_Disp (C: in out Speed_Camera'Class) is + begin + -- Dispatching calls: + Focus (C); + Set_Shutter_Speed (C); + end Self_Test_Disp; + + procedure Set_Shutter_Speed (C: in out Speed_Camera) is + begin + -- Artificial for testing purposes. + C.TC_Shutter_Called := Body_In_Instance; + end Set_Shutter_Speed; + + procedure Focus (C: in out Speed_Camera) is + begin + -- Artificial for testing purposes. + C.TC_Focus_Called := Body_In_Instance; + end Focus; + +end CC30002_1; + + + --==================================================================-- + + +with CC30002_0; +package CC30002_2 is + + type Aperture_Camera is new CC30002_0.Camera with record + FStop: Natural; + -- ...Other components. + end record; + + procedure Set_Shutter_Speed (C: in out Aperture_Camera); + procedure Focus (C: in out Aperture_Camera); + +end CC30002_2; + + + --==================================================================-- + + +package body CC30002_2 is + + procedure Set_Shutter_Speed (C: in out Aperture_Camera) is + use CC30002_0; + begin + -- Artificial for testing purposes. + C.TC_Shutter_Called := Body_Of_Actual; + end Set_Shutter_Speed; + + procedure Focus (C: in out Aperture_Camera) is + use CC30002_0; + begin + -- Artificial for testing purposes. + C.TC_Focus_Called := Body_Of_Actual; + end Focus; + +end CC30002_2; + + + --==================================================================-- + + +-- Instance declaration. + +with CC30002_1; +with CC30002_2; +package CC30002_3 is new CC30002_1 (Camera_Type => CC30002_2.Aperture_Camera); + + + --==================================================================-- + + +with CC30002_0; +with CC30002_1; +with CC30002_2; +with CC30002_3; -- Instance. + +with Report; +procedure CC30002 is + + package Speed_Cameras renames CC30002_3; + + use CC30002_0; + + TC_Camera1: Speed_Cameras.Speed_Camera; + TC_Camera2: Speed_Cameras.Speed_Camera'Class := TC_Camera1; + TC_Camera3: Speed_Cameras.Speed_Camera; + TC_Camera4: Speed_Cameras.Speed_Camera; + +begin + Report.Test ("CC30002", "Check that an explicit declaration in the " & + "private part of an instance does not override an implicit " & + "declaration in the instance, unless the corresponding " & + "explicit declaration in the generic overrides a " & + "corresponding implicit declaration in the generic. Check " & + "for primitive subprograms of tagged types"); + +-- +-- Check non-dispatching calls outside instance: +-- + + -- Non-overriding primitive operation: + + Speed_Cameras.Set_Shutter_Speed (TC_Camera1); + if TC_Camera1.TC_Shutter_Called /= Body_Of_Actual then + Report.Failed ("Wrong body executed: non-dispatching call to " & + "Set_Shutter_Speed outside instance"); + end if; + + + -- Overriding primitive operation: + + Speed_Cameras.Focus (TC_Camera1); + if TC_Camera1.TC_Focus_Called /= Body_In_Instance then + Report.Failed ("Wrong body executed: non-dispatching call to " & + "Focus outside instance"); + end if; + + +-- +-- Check dispatching calls outside instance: +-- + + -- Non-overriding primitive operation: + + Speed_Cameras.Set_Shutter_Speed (TC_Camera2); + if TC_Camera2.TC_Shutter_Called /= Body_Of_Actual then + Report.Failed ("Wrong body executed: dispatching call to " & + "Set_Shutter_Speed outside instance"); + end if; + + + -- Overriding primitive operation: + + Speed_Cameras.Focus (TC_Camera2); + if TC_Camera2.TC_Focus_Called /= Body_In_Instance then + Report.Failed ("Wrong body executed: dispatching call to " & + "Focus outside instance"); + end if; + + + +-- +-- Check non-dispatching calls within instance: +-- + + Speed_Cameras.Self_Test_NonDisp (TC_Camera3); + + -- Non-overriding primitive operation: + + if TC_Camera3.TC_Shutter_Called /= Body_In_Instance then + Report.Failed ("Wrong body executed: non-dispatching call to " & + "Set_Shutter_Speed inside instance"); + end if; + + -- Overriding primitive operation: + + if TC_Camera3.TC_Focus_Called /= Body_In_Instance then + Report.Failed ("Wrong body executed: non-dispatching call to " & + "Focus inside instance"); + end if; + + + +-- +-- Check dispatching calls within instance: +-- + + Speed_Cameras.Self_Test_Disp (TC_Camera4); + + -- Non-overriding primitive operation: + + if TC_Camera4.TC_Shutter_Called /= Body_In_Instance then + Report.Failed ("Wrong body executed: dispatching call to " & + "Set_Shutter_Speed inside instance"); + end if; + + -- Overriding primitive operation: + + if TC_Camera4.TC_Focus_Called /= Body_In_Instance then + Report.Failed ("Wrong body executed: dispatching call to " & + "Focus inside instance"); + end if; + + Report.Result; +end CC30002; diff --git a/gcc/testsuite/ada/acats/tests/cc/cc3004a.ada b/gcc/testsuite/ada/acats/tests/cc/cc3004a.ada new file mode 100644 index 000000000..5e65adf63 --- /dev/null +++ b/gcc/testsuite/ada/acats/tests/cc/cc3004a.ada @@ -0,0 +1,87 @@ +-- CC3004A.ADA + +-- Grant of Unlimited Rights +-- +-- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687, +-- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained +-- unlimited rights in the software and documentation contained herein. +-- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making +-- this public release, the Government intends to confer upon all +-- recipients unlimited rights equal to those held by the Government. +-- These rights include rights to use, duplicate, release or disclose the +-- released technical data and computer software in whole or in part, in +-- any manner and for any purpose whatsoever, and to have or permit others +-- to do so. +-- +-- DISCLAIMER +-- +-- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR +-- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED +-- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE +-- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE +-- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A +-- PARTICULAR PURPOSE OF SAID MATERIAL. +--* +-- CHECK THAT ACTUAL PARAMETERS IN A NAMED GENERIC ACTUAL PARAMETER +-- ASSOCIATION MAY BE OUT OF ORDER, AND ARE ASSOCIATED WITH THE +-- CORRECT FORMALS. + +-- DAT 9/16/81 +-- SPS 10/26/82 + +WITH REPORT; USE REPORT; + +PROCEDURE CC3004A IS +BEGIN + TEST ("CC3004A", "ORDER OF NAMED GENERIC ACTUAL PARAMETERS"); + + DECLARE + GENERIC + A,B : INTEGER; + C : INTEGER; + D : INTEGER; + PACKAGE P1 IS END P1; + + TYPE AI IS ACCESS INTEGER; + + GENERIC + TYPE D IS ( <> ); + VD : D; + TYPE AD IS ACCESS D; + VA : AD; + PACKAGE P2 IS END P2; + + X : AI := NEW INTEGER '(IDENT_INT(23)); + Y : AI := NEW INTEGER '(IDENT_INT(77)); + + PACKAGE BODY P1 IS + BEGIN + IF A /= IDENT_INT(4) OR + B /= IDENT_INT(12) OR + C /= IDENT_INT(11) OR + D /= IDENT_INT(-33) + THEN + FAILED ("WRONG GENERIC PARAMETER ASSOCIATIONS"); + END IF; + END P1; + + PACKAGE BODY P2 IS + BEGIN + IF VA.ALL /= VD THEN + FAILED ("WRONG GENERIC PARM ASSOCIATIONS 2"); + END IF; + END P2; + + PACKAGE N1 IS NEW P1 (C => 11, A => 4, D => -33, B => 12); + + PACKAGE N2 IS NEW P2 (VA => X, AD => AI, D => INTEGER, + VD => 23); + + PACKAGE N3 IS NEW P2 (INTEGER, 77, VA => Y, AD => AI); + + BEGIN + NULL; + END; + + RESULT; +END CC3004A; diff --git a/gcc/testsuite/ada/acats/tests/cc/cc3007a.ada b/gcc/testsuite/ada/acats/tests/cc/cc3007a.ada new file mode 100644 index 000000000..e9d6daa8d --- /dev/null +++ b/gcc/testsuite/ada/acats/tests/cc/cc3007a.ada @@ -0,0 +1,118 @@ +-- CC3007A.ADA + +-- Grant of Unlimited Rights +-- +-- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687, +-- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained +-- unlimited rights in the software and documentation contained herein. +-- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making +-- this public release, the Government intends to confer upon all +-- recipients unlimited rights equal to those held by the Government. +-- These rights include rights to use, duplicate, release or disclose the +-- released technical data and computer software in whole or in part, in +-- any manner and for any purpose whatsoever, and to have or permit others +-- to do so. +-- +-- DISCLAIMER +-- +-- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR +-- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED +-- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF 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 NAMES IN A GENERIC DECLARATIONS ARE STATICALLY BOUND. + +-- DAT 9/18/81 +-- SPS 2/7/83 + +WITH REPORT; USE REPORT; + +PROCEDURE CC3007A IS +BEGIN + TEST ("CC3007A", "NAMES IN GENERICS ARE STATICALLY BOUND"); + + DECLARE + I : INTEGER := 1; + EX : EXCEPTION; + IA : INTEGER := I'SIZE; + + FUNCTION F (X : INTEGER) RETURN INTEGER; + + PACKAGE P IS + Q : INTEGER := 1; + END P; + + GENERIC + J : IN OUT INTEGER; + WITH FUNCTION FP (X : INTEGER) RETURN INTEGER IS F; + PACKAGE GP IS + V1 : INTEGER := F(I); + V2 : INTEGER := FP(I); + END GP; + + GENERIC + TYPE T IS RANGE <> ; + WITH FUNCTION F1 (X : INTEGER) RETURN INTEGER IS F; + INP : IN T := T (I'SIZE); + FUNCTION F1 (X : T) RETURN T; + + FUNCTION F1 (X : T) RETURN T IS + BEGIN + IF INP /= T(IA) THEN + FAILED ("INCORRECT GENERIC BINDING 2"); + END IF; + I := I + 1; + RETURN 2 * T (F1 (F (INTEGER (X) + I + P.Q))); + END F1; + + PACKAGE BODY GP IS + PACKAGE P IS + Q : INTEGER := I + 1; + END P; + I : INTEGER := 1000; + FUNCTION F IS NEW F1 (INTEGER); + FUNCTION F2 IS NEW F1 (INTEGER); + BEGIN + P.Q := F2 (J + P.Q + V1 + 2 * V2); + J := P.Q; + RAISE EX; + END GP; + + FUNCTION F (X : INTEGER) RETURN INTEGER IS + BEGIN + I := I + 2; + RETURN X + I; + END; + BEGIN + DECLARE + I : INTEGER := 1000; + EX : EXCEPTION; + FUNCTION F IS NEW F1 (INTEGER); + V : INTEGER := F (3); + BEGIN + BEGIN + DECLARE + PACKAGE P IS NEW GP (V); + BEGIN + FAILED ("EX NOT RAISED"); + END; + EXCEPTION + WHEN EX => + FAILED ("WRONG EXCEPTION RAISED"); + WHEN OTHERS => + IF V /= 266 THEN + FAILED ("WRONG BINDING IN GENERICS"); + END IF; + RAISE; + END; + + END; + EXCEPTION + WHEN EX => NULL; + WHEN OTHERS => FAILED ("WRONG EXCEPTION RAISED 2"); + END; + + RESULT; +END CC3007A; diff --git a/gcc/testsuite/ada/acats/tests/cc/cc3007b.ada b/gcc/testsuite/ada/acats/tests/cc/cc3007b.ada new file mode 100644 index 000000000..22bd4c0a3 --- /dev/null +++ b/gcc/testsuite/ada/acats/tests/cc/cc3007b.ada @@ -0,0 +1,397 @@ +-- CC3007B.ADA + +-- Grant of Unlimited Rights +-- +-- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687, +-- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained +-- unlimited rights in the software and documentation contained herein. +-- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making +-- this public release, the Government intends to confer upon all +-- recipients unlimited rights equal to those held by the Government. +-- These rights include rights to use, duplicate, release or disclose the +-- released technical data and computer software in whole or in part, in +-- any manner and for any purpose whatsoever, and to have or permit others +-- to do so. +-- +-- DISCLAIMER +-- +-- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR +-- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED +-- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF 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 NAMES IN A GENERIC INSTANTIATION ARE STATICALLY +-- IDENTIFIED (I.E., BOUND) AT THE TEXTUAL POINT OF THE INSTANTIA- +-- TION, AND ARE BOUND BEFORE BEING "SUBSTITUTED" FOR THE COR- +-- RESPONDING GENERIC FORMAL PARAMETERS IN THE SPECIFICATION AND +-- BODY TEMPLATES. +-- +-- SEE AI-00365/05-BI-WJ. + +-- HISTORY: +-- EDWARD V. BERARD, 15 AUGUST 1990 +-- DAS 08 OCT 90 CHANGED INSTANTIATIONS TO USE VARIABLES +-- M1 AND M2 IN THE FIRST_BLOCK INSTANTIA- +-- TION AND TO ASSIGN THIRD_DATE AND +-- FOURTH_DATE VALUES BEFORE AND AFTER THE +-- SECOND_BLOCK INSTANTIATION. + +WITH REPORT; + +PROCEDURE CC3007B IS + + INCREMENTED_VALUE : NATURAL := 0; + + TYPE MONTH_TYPE IS (JAN, FEB, MAR, APR, MAY, JUN, JUL, AUG, + SEP, OCT, NOV, DEC); + TYPE DAY_TYPE IS RANGE 1 .. 31; + TYPE YEAR_TYPE IS RANGE 1904 .. 2050; + TYPE DATE IS RECORD + MONTH : MONTH_TYPE; + DAY : DAY_TYPE; + YEAR : YEAR_TYPE; + END RECORD; + + TYPE DATE_ACCESS IS ACCESS DATE; + + TODAY : DATE := (MONTH => AUG, + DAY => 8, + YEAR => 1990); + + CHRISTMAS : DATE := (MONTH => DEC, + DAY => 25, + YEAR => 1948); + + WALL_DATE : DATE := (MONTH => NOV, + DAY => 9, + YEAR => 1989); + + BIRTH_DATE : DATE := (MONTH => OCT, + DAY => 3, + YEAR => 1949); + + FIRST_DUE_DATE : DATE := (MONTH => JAN, + DAY => 23, + YEAR => 1990); + + LAST_DUE_DATE : DATE := (MONTH => DEC, + DAY => 20, + YEAR => 1990); + + THIS_MONTH : MONTH_TYPE := AUG; + + STORED_RECORD : DATE := TODAY; + + STORED_INDEX : MONTH_TYPE := AUG; + + FIRST_DATE : DATE_ACCESS := NEW DATE'(WALL_DATE); + SECOND_DATE : DATE_ACCESS := FIRST_DATE; + + THIRD_DATE : DATE_ACCESS := NEW DATE'(BIRTH_DATE); + FOURTH_DATE : DATE_ACCESS := NEW DATE'(CHRISTMAS); + + TYPE DUE_DATES IS ARRAY (MONTH_TYPE RANGE JAN .. DEC) OF DATE; + REPORT_DATES : DUE_DATES := ((JAN, 23, 1990), (FEB, 23, 1990), + (MAR, 23, 1990), (APR, 23, 1990), + (MAY, 23, 1990), (JUN, 22, 1990), + (JUL, 23, 1990), (AUG, 23, 1990), + (SEP, 24, 1990), (OCT, 23, 1990), + (NOV, 23, 1990), (DEC, 20, 1990)); + + GENERIC + + NATURALLY : IN NATURAL; + FIRST_RECORD : IN OUT DATE; + SECOND_RECORD : IN OUT DATE; + TYPE RECORD_POINTER IS ACCESS DATE; + POINTER : IN OUT RECORD_POINTER; + TYPE ARRAY_TYPE IS ARRAY (MONTH_TYPE) OF DATE; + THIS_ARRAY : IN OUT ARRAY_TYPE; + FIRST_ARRAY_ELEMENT : IN OUT DATE; + SECOND_ARRAY_ELEMENT : IN OUT DATE; + INDEX_ELEMENT : IN OUT MONTH_TYPE; + POINTER_TEST : IN OUT DATE; + ANOTHER_POINTER_TEST : IN OUT DATE; + + PACKAGE TEST_ACTUAL_PARAMETERS IS + + PROCEDURE EVALUATE_FUNCTION; + PROCEDURE CHECK_RECORDS; + PROCEDURE CHECK_ACCESS; + PROCEDURE CHECK_ARRAY; + PROCEDURE CHECK_ARRAY_ELEMENTS; + PROCEDURE CHECK_SCALAR; + PROCEDURE CHECK_POINTERS; + + END TEST_ACTUAL_PARAMETERS; + + PACKAGE BODY TEST_ACTUAL_PARAMETERS IS + + PROCEDURE EVALUATE_FUNCTION IS + BEGIN -- EVALUATE_FUNCTION + + IF (INCREMENTED_VALUE = 0) OR + (NATURALLY /= INCREMENTED_VALUE) THEN + REPORT.FAILED ("PROBLEMS EVALUATING FUNCTION " & + "PARAMETER."); + END IF; + + END EVALUATE_FUNCTION; + + PROCEDURE CHECK_RECORDS IS + + STORE : DATE; + + BEGIN -- CHECK_RECORDS + + IF STORED_RECORD /= FIRST_RECORD THEN + REPORT.FAILED ("PROBLEM WITH RECORD TYPES"); + ELSE + STORED_RECORD := SECOND_RECORD; + STORE := FIRST_RECORD; + FIRST_RECORD := SECOND_RECORD; + SECOND_RECORD := STORE; + END IF; + + END CHECK_RECORDS; + + PROCEDURE CHECK_ACCESS IS + BEGIN -- CHECK_ACCESS + + IF ((INCREMENTED_VALUE / 2) * 2) /= INCREMENTED_VALUE + THEN + IF POINTER.ALL /= DATE'(WALL_DATE) THEN + REPORT.FAILED ("PROBLEM WITH ACCESS TYPES " & + "- 1"); + ELSE + POINTER.ALL := DATE'(BIRTH_DATE); + END IF; + ELSE + IF POINTER.ALL /= DATE'(BIRTH_DATE) THEN + REPORT.FAILED ("PROBLEM WITH ACCESS TYPES " & + "- 2"); + ELSE + POINTER.ALL := DATE'(WALL_DATE); + END IF; + END IF; + + END CHECK_ACCESS; + + PROCEDURE CHECK_ARRAY IS + + STORE : DATE; + + BEGIN -- CHECK_ARRAY + + IF ((INCREMENTED_VALUE / 2) * 2) /= INCREMENTED_VALUE + THEN + IF THIS_ARRAY (THIS_ARRAY'FIRST) /= FIRST_DUE_DATE + THEN + REPORT.FAILED ("PROBLEM WITH ARRAY TYPES - 1"); + ELSE + THIS_ARRAY (THIS_ARRAY'FIRST) := LAST_DUE_DATE; + THIS_ARRAY (THIS_ARRAY'LAST) := FIRST_DUE_DATE; + END IF; + ELSE + IF THIS_ARRAY (THIS_ARRAY'FIRST) /= LAST_DUE_DATE + THEN + REPORT.FAILED ("PROBLEM WITH ARRAY TYPES - 2"); + ELSE + THIS_ARRAY (THIS_ARRAY'FIRST) := + FIRST_DUE_DATE; + THIS_ARRAY (THIS_ARRAY'LAST) := LAST_DUE_DATE; + END IF; + END IF; + + END CHECK_ARRAY; + + PROCEDURE CHECK_ARRAY_ELEMENTS IS + + STORE : DATE; + + BEGIN -- CHECK_ARRAY_ELEMENTS + + IF ((INCREMENTED_VALUE / 2) * 2) /= INCREMENTED_VALUE + THEN + IF (FIRST_ARRAY_ELEMENT.MONTH /= MAY) OR + (SECOND_ARRAY_ELEMENT.DAY /= 22) THEN + REPORT.FAILED ("PROBLEM WITH ARRAY ELEMENTS " & + "- 1"); + ELSE + STORE := FIRST_ARRAY_ELEMENT; + FIRST_ARRAY_ELEMENT := SECOND_ARRAY_ELEMENT; + SECOND_ARRAY_ELEMENT := STORE; + END IF; + ELSE + IF (FIRST_ARRAY_ELEMENT.MONTH /= JUN) OR + (SECOND_ARRAY_ELEMENT.DAY /= 23) THEN + REPORT.FAILED ("PROBLEM WITH ARRAY ELEMENTS " & + "- 2"); + ELSE + STORE := FIRST_ARRAY_ELEMENT; + FIRST_ARRAY_ELEMENT := SECOND_ARRAY_ELEMENT; + SECOND_ARRAY_ELEMENT := STORE; + END IF; + END IF; + + END CHECK_ARRAY_ELEMENTS; + + PROCEDURE CHECK_SCALAR IS + BEGIN -- CHECK_SCALAR + + IF ((INCREMENTED_VALUE / 2) * 2) /= INCREMENTED_VALUE + THEN + IF INDEX_ELEMENT /= STORED_INDEX THEN + REPORT.FAILED ("PROBLEM WITH INDEX TYPES - 1"); + ELSE + INDEX_ELEMENT := + MONTH_TYPE'SUCC(INDEX_ELEMENT); + STORED_INDEX := INDEX_ELEMENT; + END IF; + ELSE + IF INDEX_ELEMENT /= STORED_INDEX THEN + REPORT.FAILED ("PROBLEM WITH INDEX TYPES - 2"); + ELSE + INDEX_ELEMENT := + MONTH_TYPE'PRED (INDEX_ELEMENT); + STORED_INDEX := INDEX_ELEMENT; + END IF; + END IF; + + END CHECK_SCALAR; + + PROCEDURE CHECK_POINTERS IS + + STORE : DATE; + + BEGIN -- CHECK_POINTERS + + IF ((INCREMENTED_VALUE / 2) * 2) /= INCREMENTED_VALUE + THEN + IF (POINTER_TEST /= DATE'(OCT, 3, 1949)) OR + (ANOTHER_POINTER_TEST /= DATE'(DEC, 25, 1948)) + THEN + REPORT.FAILED ("PROBLEM WITH POINTER TEST " & + "- 1"); + ELSE + STORE := POINTER_TEST; + POINTER_TEST := ANOTHER_POINTER_TEST; + ANOTHER_POINTER_TEST := STORE; + END IF; + ELSE + IF (POINTER_TEST /= DATE'(DEC, 25, 1948)) OR + (ANOTHER_POINTER_TEST /= DATE'(OCT, 3, 1949)) + THEN + REPORT.FAILED ("PROBLEM WITH POINTER TEST " & + "- 2"); + ELSE + STORE := POINTER_TEST; + POINTER_TEST := ANOTHER_POINTER_TEST; + ANOTHER_POINTER_TEST := STORE; + END IF; + END IF; + + END CHECK_POINTERS; + + END TEST_ACTUAL_PARAMETERS; + + FUNCTION INC RETURN NATURAL IS + BEGIN -- INC + INCREMENTED_VALUE := NATURAL'SUCC (INCREMENTED_VALUE); + RETURN INCREMENTED_VALUE; + END INC; + +BEGIN -- CC3007B + + REPORT.TEST ("CC3007B", "CHECK THAT THE NAMES IN A GENERIC " & + "INSTANTIATION ARE STAICALLY IDENTIFIED (I.E., " & + "BOUND) AT THE TEXTUAL POINT OF THE INSTANTIATION" & + ", AND ARE BOUND BEFORE BEING SUBSTITUTED FOR " & + "THE CORRESPONDING GENERIC FORMAL PARAMETERS IN " & + "THE SPECIFICATION AND BODY TEMPLATES. " & + "SEE AI-00365/05-BI-WJ."); + + FIRST_BLOCK: + + DECLARE + + M1 : MONTH_TYPE := MAY; + M2 : MONTH_TYPE := JUN; + + PACKAGE NEW_TEST_ACTUAL_PARAMETERS IS + NEW TEST_ACTUAL_PARAMETERS ( + NATURALLY => INC, + FIRST_RECORD => TODAY, + SECOND_RECORD => CHRISTMAS, + RECORD_POINTER => DATE_ACCESS, + POINTER => SECOND_DATE, + ARRAY_TYPE => DUE_DATES, + THIS_ARRAY => REPORT_DATES, + FIRST_ARRAY_ELEMENT => REPORT_DATES (M1), + SECOND_ARRAY_ELEMENT => REPORT_DATES (M2), + INDEX_ELEMENT => THIS_MONTH, + POINTER_TEST => THIRD_DATE.ALL, + ANOTHER_POINTER_TEST => FOURTH_DATE.ALL); + + BEGIN -- FIRST_BLOCK + + REPORT.COMMENT ("ENTERING FIRST BLOCK"); + NEW_TEST_ACTUAL_PARAMETERS.EVALUATE_FUNCTION; + NEW_TEST_ACTUAL_PARAMETERS.CHECK_SCALAR; + M1 := SEP; + M2 := OCT; + -- NEW_TEST_ACTUAL_PARAMETERS SHOULD USE THE PREVIOUS + -- VALUES OF MAY AND JUN. + NEW_TEST_ACTUAL_PARAMETERS.CHECK_ARRAY; + NEW_TEST_ACTUAL_PARAMETERS.CHECK_ARRAY_ELEMENTS; + NEW_TEST_ACTUAL_PARAMETERS.CHECK_ACCESS; + NEW_TEST_ACTUAL_PARAMETERS.CHECK_RECORDS; + NEW_TEST_ACTUAL_PARAMETERS.CHECK_POINTERS; + + END FIRST_BLOCK; + + SECOND_BLOCK: + + DECLARE + + SAVE_THIRD_DATE : DATE_ACCESS := THIRD_DATE; + SAVE_FOURTH_DATE : DATE_ACCESS := FOURTH_DATE; + + PACKAGE NEW_TEST_ACTUAL_PARAMETERS IS + NEW TEST_ACTUAL_PARAMETERS ( + NATURALLY => INC, + FIRST_RECORD => TODAY, + SECOND_RECORD => CHRISTMAS, + RECORD_POINTER => DATE_ACCESS, + POINTER => SECOND_DATE, + ARRAY_TYPE => DUE_DATES, + THIS_ARRAY => REPORT_DATES, + FIRST_ARRAY_ELEMENT => REPORT_DATES (MAY), + SECOND_ARRAY_ELEMENT => REPORT_DATES (JUN), + INDEX_ELEMENT => THIS_MONTH, + POINTER_TEST => THIRD_DATE.ALL, + ANOTHER_POINTER_TEST => FOURTH_DATE.ALL); + + BEGIN -- SECOND_BLOCK + + REPORT.COMMENT ("ENTERING SECOND BLOCK"); + NEW_TEST_ACTUAL_PARAMETERS.EVALUATE_FUNCTION; + NEW_TEST_ACTUAL_PARAMETERS.CHECK_SCALAR; + NEW_TEST_ACTUAL_PARAMETERS.CHECK_ARRAY; + NEW_TEST_ACTUAL_PARAMETERS.CHECK_ARRAY_ELEMENTS; + NEW_TEST_ACTUAL_PARAMETERS.CHECK_ACCESS; + NEW_TEST_ACTUAL_PARAMETERS.CHECK_RECORDS; + + THIRD_DATE := NEW DATE'(JUL, 13, 1951); + FOURTH_DATE := NEW DATE'(JUL, 4, 1976); + NEW_TEST_ACTUAL_PARAMETERS.CHECK_POINTERS; + THIRD_DATE := SAVE_THIRD_DATE; + FOURTH_DATE := SAVE_FOURTH_DATE; + + END SECOND_BLOCK; + + REPORT.RESULT; + +END CC3007B; diff --git a/gcc/testsuite/ada/acats/tests/cc/cc3011a.ada b/gcc/testsuite/ada/acats/tests/cc/cc3011a.ada new file mode 100644 index 000000000..8ecba226e --- /dev/null +++ b/gcc/testsuite/ada/acats/tests/cc/cc3011a.ada @@ -0,0 +1,131 @@ +-- CC3011A.ADA + +-- Grant of Unlimited Rights +-- +-- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687, +-- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained +-- unlimited rights in the software and documentation contained herein. +-- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making +-- this public release, the Government intends to confer upon all +-- recipients unlimited rights equal to those held by the Government. +-- These rights include rights to use, duplicate, release or disclose the +-- released technical data and computer software in whole or in part, in +-- any manner and for any purpose whatsoever, and to have or permit others +-- to do so. +-- +-- DISCLAIMER +-- +-- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR +-- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED +-- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF 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 SUBPROGRAMS THAT WOULD HAVE THE SAME SPECIFICATION +-- AFTER GENERIC INSTANTIATION MAY BE DECLARED IN THE SAME +-- DECLARATIVE PART, AND THAT CALLS WITHIN THE INSTANTIATED UNIT ARE +-- UNAMBIGUOUS. CHECK THAT CALLS FROM OUTSIDE THE UNIT ARE UNAMBIGUOUS +-- IF FORMAL PARAMETER NAMES ARE USED OR IF ONLY ONE OF THE EQUIVALENT +-- PROGRAMS APPEARS IN THE VISIBLE PART OF THE PACKAGE. + +-- DAT 9/18/81 +-- SPS 10/19/82 + +WITH REPORT; USE REPORT; + +PROCEDURE CC3011A IS +BEGIN + TEST ("CC3011A", "CHECK SUBPROGRAMS IN GENERIC PACKAGES WITH SAME" + & " SPECIFICATION AFTER GENERIC PARAMETER SUBSTITUTION"); + + DECLARE + C : INTEGER := 0; + + GENERIC + TYPE S IS ( <> ); + TYPE T IS PRIVATE; + TYPE U IS RANGE <> ; + VT : T; + PACKAGE PKG IS + PROCEDURE P1 (X : S); + PRIVATE + PROCEDURE P1 (X : T); + VS : S := S'FIRST; + VU : U := U'FIRST; + END PKG; + + GENERIC + TYPE S IS (<>); + TYPE T IS RANGE <>; + PACKAGE PP IS + PROCEDURE P1 (D: S); + PROCEDURE P1 (X: T); + END PP; + + PACKAGE BODY PKG IS + PROCEDURE P1 (X : S) IS + BEGIN + C := C + 1; + END P1; + PROCEDURE P1 (X : T) IS + BEGIN + C := C + 2; + END P1; + PROCEDURE P1 (X : U) IS + BEGIN + C := C + 4; + END P1; + BEGIN + C := 0; + P1 (VS); + IF C /= IDENT_INT (1) THEN + FAILED ("WRONG P1 CALLED -S"); + END IF; + C := 0; + P1 (VT); + IF C /= IDENT_INT (2) THEN + FAILED ("WRONG P1 CALLED -T"); + END IF; + C := 0; + P1 (VU); + IF C /= IDENT_INT (4) THEN + FAILED ("WRONG P1 CALLED -U"); + END IF; + C := 0; + END PKG; + + PACKAGE BODY PP IS + PROCEDURE P1 (D: S) IS + BEGIN + C := C + 3; + END P1; + PROCEDURE P1 (X: T) IS + BEGIN + C := C + 5; + END P1; + BEGIN + NULL; + END PP; + + PACKAGE NP IS NEW PKG (INTEGER, INTEGER, INTEGER, 7); + PACKAGE NPP IS NEW PP (INTEGER, INTEGER); + BEGIN + NP.P1 (4); + IF C /= IDENT_INT (1) THEN + FAILED ("INCORRECT OVERLOADING ON FORMAL TYPES"); + END IF; + C := 0; + NPP.P1 (D => 3); + IF C /= IDENT_INT (3) THEN + FAILED ("INCORRECT CALL TO P1 WITH D PARAMETER"); + END IF; + C := 0; + NPP.P1 (X => 7); + IF C /= IDENT_INT (5) THEN + FAILED ("INCORRECT CALL TO P1 WITH X PARAMETER"); + END IF; + END; + + RESULT; +END CC3011A; diff --git a/gcc/testsuite/ada/acats/tests/cc/cc3011d.ada b/gcc/testsuite/ada/acats/tests/cc/cc3011d.ada new file mode 100644 index 000000000..26dfde26a --- /dev/null +++ b/gcc/testsuite/ada/acats/tests/cc/cc3011d.ada @@ -0,0 +1,84 @@ +-- CC3011D.ADA + +-- Grant of Unlimited Rights +-- +-- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687, +-- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained +-- unlimited rights in the software and documentation contained herein. +-- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making +-- this public release, the Government intends to confer upon all +-- recipients unlimited rights equal to those held by the Government. +-- These rights include rights to use, duplicate, release or disclose the +-- released technical data and computer software in whole or in part, in +-- any manner and for any purpose whatsoever, and to have or permit others +-- to do so. +-- +-- DISCLAIMER +-- +-- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR +-- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED +-- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF 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 WHEN A GENERIC PACKAGE INSTANTIATION CONTAINS DECLARATIONS +-- OF SUBPROGRAMS WITH THE SAME SPECIFICATIONS, THE CALLS TO THE +-- SUBPROGRAMS ARE NOT AMBIGIOUS WITHIN THE GENERIC BODY. + +-- SPS 5/7/82 +-- SPS 2/7/83 + +WITH REPORT; USE REPORT; + +PROCEDURE CC3011D IS +BEGIN + TEST ("CC3011D", "SUBPROGRAMS WITH SAME SPECIFICATIONS NOT" + & " AMBIGIOUS WITHIN GENERIC BODY"); + + DECLARE + TYPE FLAG IS (PRT,PRS); + XX : FLAG; + + GENERIC + TYPE S IS PRIVATE; + TYPE T IS PRIVATE; + V1 : S; + V2 : T; + PACKAGE P1 IS + PROCEDURE PR(X : S); + PROCEDURE PR(X : T); + END P1; + + PACKAGE BODY P1 IS + PROCEDURE PR (X : S) IS + BEGIN + XX := PRS; + END; + + PROCEDURE PR (X : T ) IS + BEGIN + XX := PRT; + END; + + BEGIN + XX := PRT; + PR (V1); + IF XX /= PRS THEN + FAILED ("WRONG BINDING FOR PR WITH TYPE S"); + END IF; + XX := PRS; + PR (V2); + IF XX /= PRT THEN + FAILED ("WRONG BINDING FOR PR WITH TYPE T"); + END IF; + END P1; + + PACKAGE PAK IS NEW P1 (INTEGER, INTEGER, 1, 2); + + BEGIN + NULL; + END; + + RESULT; +END CC3011D; diff --git a/gcc/testsuite/ada/acats/tests/cc/cc3012a.ada b/gcc/testsuite/ada/acats/tests/cc/cc3012a.ada new file mode 100644 index 000000000..da465017d --- /dev/null +++ b/gcc/testsuite/ada/acats/tests/cc/cc3012a.ada @@ -0,0 +1,247 @@ +-- CC3012A.ADA + +-- Grant of Unlimited Rights +-- +-- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687, +-- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained +-- unlimited rights in the software and documentation contained herein. +-- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making +-- this public release, the Government intends to confer upon all +-- recipients unlimited rights equal to those held by the Government. +-- These rights include rights to use, duplicate, release or disclose the +-- released technical data and computer software in whole or in part, in +-- any manner and for any purpose whatsoever, and to have or permit others +-- to do so. +-- +-- DISCLAIMER +-- +-- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR +-- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED +-- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF 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 GENERIC INSTANCES MAY BE OVERLOADED. + +-- CHECK THAT THEY MAY OVERLOAD PREVIOUSLY DECLARED SUBPROGRAMS AND +-- ENUMERATION LITERALS. + +-- DAT 9/16/81 +-- SPS 10/19/82 +-- SPS 2/8/83 +-- PWN 11/30/94 REMOVED PART OF TEST INVALID FOR ADA 9X. + + +WITH REPORT; USE REPORT; + +PROCEDURE CC3012A IS +BEGIN + TEST ("CC3012A", "CHECK THAT GENERIC INSTANCES MAY OVERLOAD " & + "OTHER IDENTIFIERS"); + + DECLARE + GENERIC + TYPE T IS ( <> ); + V : IN T; + PROCEDURE GP (X : IN OUT T); + + GENERIC + TYPE T IS ( <> ); + FUNCTION LESS (X, Y : T) RETURN BOOLEAN; + + GENERIC + TYPE T IS ( <> ); + FUNCTION PLUS (X, Y : T) RETURN T; + + GENERIC + TYPE T IS PRIVATE; + Z : T; + FUNCTION F1 RETURN T; + + TYPE DC IS NEW CHARACTER RANGE IDENT_CHAR ('A') .. 'Z'; + TYPE DI IS NEW INTEGER; + TYPE ENUM IS (E1, E2, E3, E4); + + VC : CHARACTER := 'A'; + VI : INTEGER := 5; + VB : BOOLEAN := TRUE; + VE : ENUM := E2; + + TYPE DENUM IS NEW ENUM RANGE E2 .. ENUM'LAST; + + VDE : DENUM := E4; + VDC : DC := 'A'; + VDI : DI := 7; + + PROCEDURE GP (X : IN OUT T) IS + BEGIN + X := V; + END GP; + + FUNCTION LESS (X, Y : T) RETURN BOOLEAN IS + BEGIN + RETURN FALSE; + END LESS; + + FUNCTION PLUS (X, Y : T) RETURN T IS + BEGIN + RETURN T'FIRST; + END PLUS; + + FUNCTION F1 RETURN T IS + BEGIN + RETURN Z; + END F1; + + FUNCTION E5 RETURN INTEGER IS + BEGIN + RETURN 1; + END E5; + + PACKAGE PKG IS + + PROCEDURE P IS NEW GP (CHARACTER, 'Q'); + PROCEDURE P IS NEW GP (INTEGER, -14); + PROCEDURE P IS NEW GP (BOOLEAN, FALSE); + PROCEDURE P IS NEW GP (ENUM, E4); + PROCEDURE P IS NEW GP (DC, 'W'); + PROCEDURE P IS NEW GP (DI, -33); + PROCEDURE P IS NEW GP (DENUM, E2); + + FUNCTION "<" IS NEW LESS (CHARACTER); + FUNCTION "<" IS NEW LESS (INTEGER); + FUNCTION "<" IS NEW LESS (BOOLEAN); + FUNCTION "<" IS NEW LESS (ENUM); + FUNCTION "<" IS NEW LESS (DC); + FUNCTION "<" IS NEW LESS (DI); + -- NOT FOR DENUM. + + FUNCTION "+" IS NEW PLUS (CHARACTER); + FUNCTION "+" IS NEW PLUS (INTEGER); + FUNCTION "+" IS NEW PLUS (BOOLEAN); + FUNCTION "+" IS NEW PLUS (ENUM); + FUNCTION "+" IS NEW PLUS (DC); + -- NOT FOR DI. + FUNCTION "+" IS NEW PLUS (DENUM); + + FUNCTION E2 IS NEW F1 (BOOLEAN, FALSE); + FUNCTION E5 IS NEW F1 (DC, 'M'); + + END PKG; + + PACKAGE BODY PKG IS + BEGIN + P (VC); + P (VI); + P (VB); + P (VE); + P (X => VDE); + P (X => VDC); + P (X => VDI); + + IF VC /= 'Q' THEN + FAILED ("OVERLOADED PROCEDURE - 1"); + END IF; + + IF VI /= -14 THEN + FAILED ("OVERLOADED PROCEDURE - 2"); + END IF; + + IF VB /= FALSE THEN + FAILED ("OVERLOADED PROCEDURE - 3"); + END IF; + + IF VE /= E4 THEN + FAILED ("OVERLOADED PROCEDURE - 4"); + END IF; + + IF VDE /= E2 THEN + FAILED ("OVERLOADED PROCEDURE - 5"); + END IF; + + IF VDC /= 'W' THEN + FAILED ("OVERLOADED PROCEDURE - 6"); + END IF; + + IF VDI /= -33 THEN + FAILED ("OVERLOADED PROCEDURE - 7"); + END IF; + + IF VC < ASCII.DEL THEN + FAILED ("OVERLOADED LESS THAN - 1"); + END IF; + + IF VI < 1E3 THEN + FAILED ("OVERLOADED LESS THAN - 2"); + END IF; + + IF FALSE < TRUE THEN + FAILED ("OVERLOADED LESS THAN - 3"); + END IF; + + IF E1 < VE THEN + FAILED ("OVERLOADED LESS THAN - 4"); + END IF; + + IF VDC < 'Z' THEN + FAILED ("OVERLOADED LESS THAN - 5"); + END IF; + + IF VDI < 0 THEN + FAILED ("OVERLOADED LESS THAN - 6"); + END IF; + + + IF -14 + 5 /= -9 THEN + FAILED ("OVERLOADED PLUS - 2"); + END IF; + + IF VI + 5 /= INTEGER'FIRST THEN + FAILED ("OVERLOADED PLUS - 3"); + END IF; + + IF VB + TRUE /= FALSE THEN + FAILED ("OVERLOADED PLUS - 4"); + END IF; + + IF VE + E2 /= E1 THEN + FAILED ("OVERLOADED PLUS - 5"); + END IF; + + IF DENUM'(E3) + E2 /= E2 THEN + FAILED ("OVERLOADED PLUS - 6"); + END IF; + + IF VDC + 'B' /= 'A' THEN + FAILED ("OVERLOADED PLUS - 7"); + END IF; + + IF VDI + 14 /= -19 THEN -- -33 + 14 + FAILED ("OVERLOADED PLUS - 8"); + END IF; + + VI := E5; + VDC := E5; + VE := E2; + VB := E2; + IF VI /= 1 OR + VDC /= 'M' OR + VE /= ENUM'VAL(IDENT_INT(1)) OR + VB /= FALSE THEN + FAILED ("OVERLOADING OF ENUMERATION LITERALS " & + "AND PREDEFINED SUBPROGRAMS"); + END IF; + END PKG; + BEGIN + DECLARE + USE PKG; + BEGIN + IF NOT (VI + 5 < 11) THEN + FAILED ("INCORRECT VISIBILITY OF GENERIC OVERLOADING"); + END IF; + END; + END; + + RESULT; +END CC3012A; diff --git a/gcc/testsuite/ada/acats/tests/cc/cc3015a.ada b/gcc/testsuite/ada/acats/tests/cc/cc3015a.ada new file mode 100644 index 000000000..ca3543c44 --- /dev/null +++ b/gcc/testsuite/ada/acats/tests/cc/cc3015a.ada @@ -0,0 +1,104 @@ +-- CC3015A.ADA + +-- Grant of Unlimited Rights +-- +-- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687, +-- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained +-- unlimited rights in the software and documentation contained herein. +-- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making +-- this public release, the Government intends to confer upon all +-- recipients unlimited rights equal to those held by the Government. +-- These rights include rights to use, duplicate, release or disclose the +-- released technical data and computer software in whole or in part, in +-- any manner and for any purpose whatsoever, and to have or permit others +-- to do so. +-- +-- DISCLAIMER +-- +-- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR +-- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED +-- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF 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 WHEN A GENERIC PACKAGE INSTANTIATION IS ELABORATED, +-- STATEMENTS IN ITS PACKAGE BODY ARE EXECUTED AND EXPRESSIONS +-- REQUIRING EVALUATION ARE EVALUATED (E.G., DEFAULTS FOR OBJECT +-- DECLARATIONS ARE EVALUATED). + +-- RJW 6/11/86 + +WITH REPORT; USE REPORT; + +PROCEDURE CC3015A IS + BOOL1, BOOL2 : BOOLEAN := FALSE; + + TYPE ENUM IS (BEFORE, AFTER); + + FUNCTION F (I : INTEGER) RETURN INTEGER IS + BEGIN + BOOL2 := TRUE; + RETURN I; + END; + + FUNCTION CHECK (E : ENUM) RETURN CHARACTER IS + BEGIN + IF E = BEFORE THEN + IF BOOL1 THEN + FAILED ( "STATEMENT EXECUTED BEFORE " & + "INSTANTIATION" ); + END IF; + IF BOOL2 THEN + FAILED ( "DEFAULT EXPRESSION EVALUATED " & + "BEFORE INSTANTIATION" ); + END IF; + ELSE + IF BOOL1 THEN + NULL; + ELSE + FAILED ( "STATEMENT NOT EXECUTED AT " & + "INSTANTIATION" ); + END IF; + IF BOOL2 THEN + NULL; + ELSE + FAILED ( "DEFAULT EXPRESSION NOT EVALUATED " & + "AT INSTANTIATION" ); + END IF; + END IF; + RETURN 'A'; + END; + + GENERIC + TYPE INT IS RANGE <>; + PACKAGE PKG IS END PKG; + + PACKAGE BODY PKG IS + I : INT := INT'VAL (F(0)); + BEGIN + BOOL1 := TRUE; + END; + +BEGIN + TEST ("CC3015A", "CHECK THAT WHEN A GENERIC PACKAGE " & + "INSTANTIATION IS ELABORATED, STATEMENTS " & + "IN ITS PACKAGE BODY ARE EXECUTED AND " & + "EXPRESSIONS REQUIRING EVALUATION ARE " & + "EVALUATED (E.G., DEFAULTS FOR OBJECT " & + "DECLARATIONS ARE EVALUATED)" ); + + + DECLARE + A : CHARACTER := CHECK (BEFORE); + + PACKAGE NPKG IS NEW PKG (INTEGER); + + B : CHARACTER := CHECK (AFTER); + + BEGIN + NULL; + END; + + RESULT; +END CC3015A; diff --git a/gcc/testsuite/ada/acats/tests/cc/cc3016b.ada b/gcc/testsuite/ada/acats/tests/cc/cc3016b.ada new file mode 100644 index 000000000..2fbc09062 --- /dev/null +++ b/gcc/testsuite/ada/acats/tests/cc/cc3016b.ada @@ -0,0 +1,396 @@ +-- CC3016B.ADA + +-- Grant of Unlimited Rights +-- +-- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687, +-- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained +-- unlimited rights in the software and documentation contained herein. +-- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making +-- this public release, the Government intends to confer upon all +-- recipients unlimited rights equal to those held by the Government. +-- These rights include rights to use, duplicate, release or disclose the +-- released technical data and computer software in whole or in part, in +-- any manner and for any purpose whatsoever, and to have or permit others +-- to do so. +-- +-- DISCLAIMER +-- +-- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR +-- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED +-- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF 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 INSTANCE OF A GENERIC PACKAGE MUST DECLARE A +-- PACKAGE. CHECK THAT THE DECLARATIVE ITEMS IN AN INSTANTIATION +-- OF A GENERIC PACKAGE SPECIFICATION ARE ELABORATED IN THE ORDER +-- DECLARED. + +-- HISTORY: +-- EDWARD V. BERARD, 8 AUGUST 1990 + +WITH REPORT ; + +PROCEDURE CC3016B IS + + WHEN_ELABORATED : NATURAL := 0 ; + + TYPE REAL IS DIGITS 6 ; + REAL_VALUE : REAL := 3.14159 ; + + TRUE_VALUE : BOOLEAN := TRUE ; + + CHARACTER_VALUE : CHARACTER := 'Z' ; + + TYPE MONTH_TYPE IS (JAN, FEB, MAR, APR, MAY, JUN, JUL, AUG, + SEP, OCT, NOV, DEC) ; + TYPE DAY_TYPE IS RANGE 1 .. 31 ; + TYPE YEAR_TYPE IS RANGE 1904 .. 2050 ; + TYPE DATE IS RECORD + MONTH : MONTH_TYPE ; + DAY : DAY_TYPE ; + YEAR : YEAR_TYPE ; + END RECORD ; + + TYPE DATE_ACCESS IS ACCESS DATE ; + + THIS_MONTH : MONTH_TYPE := AUG ; + THIS_YEAR : YEAR_TYPE := 1990 ; + + TODAY : DATE := (MONTH => AUG, + DAY => 8, + YEAR => 1990) ; + + FIRST_DATE : DATE_ACCESS := NEW DATE'(DAY => 6, + MONTH => JUN, + YEAR => 1967) ; + + TYPE DUE_DATES IS ARRAY (MONTH_TYPE RANGE JAN .. DEC) OF DATE ; + REPORT_DATES : DUE_DATES := ((JAN, 23, 1990), (FEB, 23, 1990), + (MAR, 23, 1990), (APR, 23, 1990), + (MAY, 23, 1990), (JUN, 22, 1990), + (JUL, 23, 1990), (AUG, 23, 1990), + (SEP, 24, 1990), (OCT, 23, 1990), + (NOV, 23, 1990), (DEC, 20, 1990)) ; + + TYPE LIST_INDEX IS RANGE 1 .. 16 ; + TYPE LIST IS ARRAY (LIST_INDEX) OF NATURAL ; + ORDER_LIST : LIST := (OTHERS => 0) ; + + GENERIC + + TYPE RETURN_TYPE IS PRIVATE ; + RETURN_VALUE : IN OUT RETURN_TYPE ; + POSITION : IN NATURAL ; + OFFSET : IN NATURAL ; + WHEN_ELAB : IN OUT NATURAL ; + TYPE INDEX IS RANGE <> ; + TYPE LIST IS ARRAY (INDEX) OF NATURAL ; + ORDER_LIST : IN OUT LIST ; + + FUNCTION NAME (VALUE : IN NATURAL) RETURN RETURN_TYPE ; + + FUNCTION NAME (VALUE : IN NATURAL) RETURN RETURN_TYPE IS + + BEGIN -- NAME + + IF (VALUE = POSITION) THEN + WHEN_ELAB := NATURAL'SUCC (WHEN_ELAB) ; + ORDER_LIST (INDEX (POSITION)) := WHEN_ELAB ; + RETURN RETURN_VALUE ; + ELSIF (VALUE = (POSITION + OFFSET)) THEN + WHEN_ELAB := NATURAL'SUCC (WHEN_ELAB) ; + ORDER_LIST (INDEX (POSITION + OFFSET)) := WHEN_ELAB ; + RETURN RETURN_VALUE ; + END IF ; + + END NAME ; + + GENERIC + + TYPE FIRST_TYPE IS PRIVATE ; + WITH FUNCTION FIRST (POSITION : IN NATURAL) + RETURN FIRST_TYPE ; + FIRST_VALUE : IN NATURAL ; + TYPE SECOND_TYPE IS PRIVATE ; + WITH FUNCTION SECOND (POSITION : IN NATURAL) + RETURN SECOND_TYPE ; + SECOND_VALUE : IN NATURAL ; + TYPE THIRD_TYPE IS PRIVATE ; + WITH FUNCTION THIRD (POSITION : IN NATURAL) + RETURN THIRD_TYPE ; + THIRD_VALUE : IN NATURAL ; + TYPE FOURTH_TYPE IS PRIVATE ; + WITH FUNCTION FOURTH (POSITION : IN NATURAL) + RETURN FOURTH_TYPE ; + FOURTH_VALUE : IN NATURAL ; + TYPE FIFTH_TYPE IS PRIVATE ; + WITH FUNCTION FIFTH (POSITION : IN NATURAL) + RETURN FIFTH_TYPE ; + FIFTH_VALUE : IN NATURAL ; + TYPE SIXTH_TYPE IS PRIVATE ; + WITH FUNCTION SIXTH (POSITION : IN NATURAL) + RETURN SIXTH_TYPE ; + SIXTH_VALUE : IN NATURAL ; + TYPE SEVENTH_TYPE IS PRIVATE ; + WITH FUNCTION SEVENTH (POSITION : IN NATURAL) + RETURN SEVENTH_TYPE ; + SEVENTH_VALUE : IN NATURAL ; + TYPE EIGHTH_TYPE IS PRIVATE ; + WITH FUNCTION EIGHTH (POSITION : IN NATURAL) + RETURN EIGHTH_TYPE ; + EIGHTH_VALUE : IN NATURAL ; + TYPE NINTH_TYPE IS PRIVATE ; + WITH FUNCTION NINTH (POSITION : IN NATURAL) + RETURN NINTH_TYPE ; + NINTH_VALUE : IN NATURAL ; + TYPE TENTH_TYPE IS PRIVATE ; + WITH FUNCTION TENTH (POSITION : IN NATURAL) + RETURN TENTH_TYPE ; + TENTH_VALUE : IN NATURAL ; + TYPE ELEVENTH_TYPE IS PRIVATE ; + WITH FUNCTION ELEVENTH (POSITION : IN NATURAL) + RETURN ELEVENTH_TYPE ; + ELEVENTH_VALUE : IN NATURAL ; + TYPE TWELFTH_TYPE IS PRIVATE ; + WITH FUNCTION TWELFTH (POSITION : IN NATURAL) + RETURN TWELFTH_TYPE ; + TWELFTH_VALUE : IN NATURAL ; + TYPE THIRTEENTH_TYPE IS PRIVATE ; + WITH FUNCTION THIRTEENTH (POSITION : IN NATURAL) + RETURN THIRTEENTH_TYPE ; + THIRTEENTH_VALUE : IN NATURAL ; + TYPE FOURTEENTH_TYPE IS PRIVATE ; + WITH FUNCTION FOURTEENTH (POSITION : IN NATURAL) + RETURN FOURTEENTH_TYPE ; + FOURTEENTH_VALUE : IN NATURAL ; + TYPE FIFTEENTH_TYPE IS PRIVATE ; + WITH FUNCTION FIFTEENTH (POSITION : IN NATURAL) + RETURN FIFTEENTH_TYPE ; + FIFTEENTH_VALUE : IN NATURAL ; + TYPE SIXTEENTH_TYPE IS PRIVATE ; + WITH FUNCTION SIXTEENTH (POSITION : IN NATURAL) + RETURN SIXTEENTH_TYPE ; + SIXTEENTH_VALUE : IN NATURAL ; + + PACKAGE ORDER_PACKAGE IS + + A : FIRST_TYPE := FIRST (FIRST_VALUE) ; + B : SECOND_TYPE := SECOND (SECOND_VALUE) ; + C : THIRD_TYPE := THIRD (THIRD_VALUE) ; + D : FOURTH_TYPE := FOURTH (FOURTH_VALUE) ; + E : FIFTH_TYPE := FIFTH (FIFTH_VALUE) ; + F : SIXTH_TYPE := SIXTH (SIXTH_VALUE) ; + G : SEVENTH_TYPE := SEVENTH (SEVENTH_VALUE) ; + H : EIGHTH_TYPE := EIGHTH (EIGHTH_VALUE) ; + I : NINTH_TYPE := NINTH (NINTH_VALUE) ; + J : TENTH_TYPE := TENTH (TENTH_VALUE) ; + K : ELEVENTH_TYPE := ELEVENTH (ELEVENTH_VALUE) ; + L : TWELFTH_TYPE := TWELFTH (TWELFTH_VALUE) ; + M : THIRTEENTH_TYPE := THIRTEENTH (THIRTEENTH_VALUE) ; + N : FOURTEENTH_TYPE := FOURTEENTH (FOURTEENTH_VALUE) ; + O : FIFTEENTH_TYPE := FIFTEENTH (FIFTEENTH_VALUE) ; + P : SIXTEENTH_TYPE := SIXTEENTH (SIXTEENTH_VALUE) ; + + END ORDER_PACKAGE ; + + + FUNCTION BOOL IS NEW NAME (RETURN_TYPE => BOOLEAN, + RETURN_VALUE => TRUE_VALUE, + POSITION => 1, + OFFSET => 8, + WHEN_ELAB => WHEN_ELABORATED, + INDEX => LIST_INDEX, + LIST => LIST, + ORDER_LIST => ORDER_LIST) ; + + FUNCTION INT IS NEW NAME (RETURN_TYPE => YEAR_TYPE, + RETURN_VALUE => THIS_YEAR, + POSITION => 2, + OFFSET => 8, + WHEN_ELAB => WHEN_ELABORATED, + INDEX => LIST_INDEX, + LIST => LIST, + ORDER_LIST => ORDER_LIST) ; + + FUNCTION FLOAT IS NEW NAME (RETURN_TYPE => REAL, + RETURN_VALUE => REAL_VALUE, + POSITION => 3, + OFFSET => 8, + WHEN_ELAB => WHEN_ELABORATED, + INDEX => LIST_INDEX, + LIST => LIST, + ORDER_LIST => ORDER_LIST) ; + + FUNCTION CHAR IS NEW NAME (RETURN_TYPE => CHARACTER, + RETURN_VALUE => CHARACTER_VALUE, + POSITION => 4, + OFFSET => 8, + WHEN_ELAB => WHEN_ELABORATED, + INDEX => LIST_INDEX, + LIST => LIST, + ORDER_LIST => ORDER_LIST) ; + + FUNCTION ENUM IS NEW NAME (RETURN_TYPE => MONTH_TYPE, + RETURN_VALUE => THIS_MONTH, + POSITION => 5, + OFFSET => 8, + WHEN_ELAB => WHEN_ELABORATED, + INDEX => LIST_INDEX, + LIST => LIST, + ORDER_LIST => ORDER_LIST) ; + + FUNCTION ARRY IS NEW NAME (RETURN_TYPE => DUE_DATES, + RETURN_VALUE => REPORT_DATES, + POSITION => 6, + OFFSET => 8, + WHEN_ELAB => WHEN_ELABORATED, + INDEX => LIST_INDEX, + LIST => LIST, + ORDER_LIST => ORDER_LIST) ; + + + FUNCTION RCRD IS NEW NAME (RETURN_TYPE => DATE, + RETURN_VALUE => TODAY, + POSITION => 7, + OFFSET => 8, + WHEN_ELAB => WHEN_ELABORATED, + INDEX => LIST_INDEX, + LIST => LIST, + ORDER_LIST => ORDER_LIST) ; + + + FUNCTION ACSS IS NEW NAME (RETURN_TYPE => DATE_ACCESS, + RETURN_VALUE => FIRST_DATE, + POSITION => 8, + OFFSET => 8, + WHEN_ELAB => WHEN_ELABORATED, + INDEX => LIST_INDEX, + LIST => LIST, + ORDER_LIST => ORDER_LIST) ; + + PACKAGE ELABORATION_ORDER IS NEW ORDER_PACKAGE + (FIRST_TYPE => BOOLEAN, + FIRST => BOOL, + FIRST_VALUE => 1, + THIRD_TYPE => REAL, + THIRD => FLOAT, + THIRD_VALUE => 3, + SECOND_TYPE => YEAR_TYPE, -- ORDERING OF PARAMETERS + SECOND => INT, -- IS DELIBERATE. + SECOND_VALUE => 2, + FOURTH_TYPE => CHARACTER, + FOURTH => CHAR, + FOURTH_VALUE => 4, + FIFTH_TYPE => MONTH_TYPE, + FIFTH => ENUM, + FIFTH_VALUE => 5, + SIXTH_TYPE => DUE_DATES, + SIXTH => ARRY, + SIXTH_VALUE => 6, + SEVENTH_TYPE => DATE, + SEVENTH => RCRD, + SEVENTH_VALUE => 7, + EIGHTH_TYPE => DATE_ACCESS, + EIGHTH => ACSS, + EIGHTH_VALUE => 8, + NINTH_TYPE => BOOLEAN, + NINTH => BOOL, + NINTH_VALUE => 9, + TENTH_TYPE => YEAR_TYPE, + TENTH => INT, + TENTH_VALUE => 10, + ELEVENTH_TYPE => REAL, + ELEVENTH => FLOAT, + ELEVENTH_VALUE => 11, + TWELFTH_TYPE => CHARACTER, + TWELFTH => CHAR, + TWELFTH_VALUE => 12, + THIRTEENTH_TYPE => MONTH_TYPE, + THIRTEENTH => ENUM, + THIRTEENTH_VALUE => 13, + FOURTEENTH_TYPE => DUE_DATES, + FOURTEENTH => ARRY, + FOURTEENTH_VALUE => 14, + FIFTEENTH_TYPE => DATE, + FIFTEENTH => RCRD, + FIFTEENTH_VALUE => 15, + SIXTEENTH_TYPE => DATE_ACCESS, + SIXTEENTH => ACSS, + SIXTEENTH_VALUE => 16) ; + +BEGIN + REPORT.TEST("CC3016B", "CHECK THAT AN INSTANCE OF A GENERIC " & + "PACKAGE MUST DECLARE A PACKAGE. CHECK THAT THE " & + "DECLARATIVE ITEMS IN AN INSTANTIATION OF A GENERIC " & + "PACKAGE SPECIFICATION ARE ELABORATED IN THE ORDER " & + "DECLARED."); + + IF ORDER_LIST(1) /= REPORT.IDENT_INT(1) THEN + REPORT.FAILED("BOOLEAN 1 ELABORATED OUT OF ORDER"); + END IF; + + IF ORDER_LIST(2) /= REPORT.IDENT_INT(2) THEN + REPORT.FAILED("INTEGER TYPE 1 ELABORATED OUT OF ORDER"); + END IF; + + IF ORDER_LIST(3) /= REPORT.IDENT_INT(3) THEN + REPORT.FAILED("REAL 1 ELABORATED OUT OF ORDER"); + END IF; + + IF ORDER_LIST(4) /= REPORT.IDENT_INT(4) THEN + REPORT.FAILED("CHARACTER 1 ELABORATED OUT OF ORDER"); + END IF; + + IF ORDER_LIST(5) /= REPORT.IDENT_INT(5) THEN + REPORT.FAILED("ENUMERATION 1 ELABORATED OUT OF ORDER"); + END IF; + + IF ORDER_LIST(6) /= REPORT.IDENT_INT(6) THEN + REPORT.FAILED("ARRAY 1 ELABORATED OUT OF ORDER"); + END IF; + + IF ORDER_LIST(7) /= REPORT.IDENT_INT(7) THEN + REPORT.FAILED("RECORD 1 ELABORATED OUT OF ORDER"); + END IF; + + IF ORDER_LIST(8) /= REPORT.IDENT_INT(8) THEN + REPORT.FAILED("ACCESS 1 ELABORATED OUT OF ORDER"); + END IF; + + IF ORDER_LIST(9) /= REPORT.IDENT_INT(9) THEN + REPORT.FAILED("BOOLEAN 2 ELABORATED OUT OF ORDER"); + END IF; + + IF ORDER_LIST(10) /= REPORT.IDENT_INT(10) THEN + REPORT.FAILED("INTEGER TYPE 2 ELABORATED OUT OF ORDER"); + END IF; + + IF ORDER_LIST(11) /= REPORT.IDENT_INT(11) THEN + REPORT.FAILED("REAL 2 ELABORATED OUT OF ORDER"); + END IF; + + IF ORDER_LIST(12) /= REPORT.IDENT_INT(12) THEN + REPORT.FAILED("CHARACTER 2 ELABORATED OUT OF ORDER"); + END IF; + + IF ORDER_LIST(13) /= REPORT.IDENT_INT(13) THEN + REPORT.FAILED("ENUMERATION 2 ELABORATED OUT OF ORDER"); + END IF; + + IF ORDER_LIST(14) /= REPORT.IDENT_INT(14) THEN + REPORT.FAILED("ARRAY 2 ELABORATED OUT OF ORDER"); + END IF; + + IF ORDER_LIST(15) /= REPORT.IDENT_INT(15) THEN + REPORT.FAILED("RECORD 2 ELABORATED OUT OF ORDER"); + END IF; + + IF ORDER_LIST(16) /= REPORT.IDENT_INT(16) THEN + REPORT.FAILED("ACCESS 2 ELABORATED OUT OF ORDER"); + END IF; + + REPORT.RESULT ; + +END CC3016B; diff --git a/gcc/testsuite/ada/acats/tests/cc/cc3016c.ada b/gcc/testsuite/ada/acats/tests/cc/cc3016c.ada new file mode 100644 index 000000000..637617027 --- /dev/null +++ b/gcc/testsuite/ada/acats/tests/cc/cc3016c.ada @@ -0,0 +1,192 @@ +-- CC3016C.ADA + +-- Grant of Unlimited Rights +-- +-- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687, +-- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained +-- unlimited rights in the software and documentation contained herein. +-- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making +-- this public release, the Government intends to confer upon all +-- recipients unlimited rights equal to those held by the Government. +-- These rights include rights to use, duplicate, release or disclose the +-- released technical data and computer software in whole or in part, in +-- any manner and for any purpose whatsoever, and to have or permit others +-- to do so. +-- +-- DISCLAIMER +-- +-- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR +-- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED +-- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF 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 INSTANCE OF A GENERIC PACKAGE MUST DECLARE A +-- PACKAGE. CHECK THAT THE STATEMENTS IN AN INSTANTIATED GENERIC +-- PACKAGE BODY ARE EXECUTED AFTER THE ELABORATION OF THE +-- DECLARATIONS (IN SPEC AND IN BODY). + +-- HISTORY: +-- EDWARD V. BERARD, 8 AUGUST 1990 + +WITH REPORT; + +PROCEDURE CC3016C IS + + GENERIC + + TYPE SOME_TYPE IS PRIVATE ; + FIRST_INITIAL_VALUE : IN SOME_TYPE ; + SECOND_INITIAL_VALUE : IN SOME_TYPE ; + WITH PROCEDURE CHANGE (FIRST : IN SOME_TYPE ; + RESULT : OUT SOME_TYPE) ; + WITH PROCEDURE SECOND_CHANGE (FIRST : IN SOME_TYPE ; + RESULT : OUT SOME_TYPE) ; + WITH PROCEDURE THIRD_CHANGE (FIRST : IN SOME_TYPE ; + RESULT : OUT SOME_TYPE) ; + FIRST_EXPECTED_RESULT : IN SOME_TYPE ; + SECOND_EXPECTED_RESULT : IN SOME_TYPE ; + THIRD_EXPECTED_RESULT : IN SOME_TYPE ; + FOURTH_EXPECTED_RESULT : IN SOME_TYPE ; + FIFTH_EXPECTED_RESULT : IN SOME_TYPE ; + SIXTH_EXPECTED_RESULT : IN SOME_TYPE ; + + PACKAGE OUTER IS + + VARIABLE : SOME_TYPE := FIRST_INITIAL_VALUE ; + + FUNCTION INNER_VARIABLE RETURN SOME_TYPE ; + + GENERIC + + INITIAL_VALUE : IN SOME_TYPE ; + WITH PROCEDURE CHANGE (FIRST : IN SOME_TYPE ; + RESULT : OUT SOME_TYPE) ; + WITH PROCEDURE SECOND_CHANGE (FIRST : IN SOME_TYPE ; + RESULT : OUT SOME_TYPE) ; + FIRST_EXPECTED_RESULT : IN SOME_TYPE ; + SECOND_EXPECTED_RESULT : IN SOME_TYPE ; + THIRD_EXPECTED_RESULT : IN SOME_TYPE ; + FOURTH_EXPECTED_RESULT : IN SOME_TYPE ; + + PACKAGE INNER IS + VARIABLE : SOME_TYPE := INITIAL_VALUE ; + END INNER ; + + END OUTER ; + + + PACKAGE BODY OUTER IS + + ANOTHER_VARIABLE : SOME_TYPE := FIRST_INITIAL_VALUE ; + + PACKAGE BODY INNER IS + ANOTHER_VARIABLE : SOME_TYPE := INITIAL_VALUE ; + BEGIN -- INNER + + CHANGE (FIRST => VARIABLE, + RESULT => VARIABLE) ; + CHANGE (FIRST => ANOTHER_VARIABLE, + RESULT => ANOTHER_VARIABLE) ; + OUTER.SECOND_CHANGE (FIRST => OUTER.VARIABLE, + RESULT => OUTER.VARIABLE) ; + OUTER.CHANGE (FIRST => OUTER.ANOTHER_VARIABLE, + RESULT => OUTER.ANOTHER_VARIABLE) ; + + IF (VARIABLE /= FIRST_EXPECTED_RESULT) OR + (ANOTHER_VARIABLE /= SECOND_EXPECTED_RESULT) OR + (OUTER.VARIABLE + /= THIRD_EXPECTED_RESULT) OR + (OUTER.ANOTHER_VARIABLE + /= FOURTH_EXPECTED_RESULT) THEN + REPORT.FAILED("ASSIGNED VALUES INCORRECT - BODY OF INNER") ; + END IF; + + END INNER ; + + PACKAGE NEW_INNER IS NEW INNER + (INITIAL_VALUE => SECOND_INITIAL_VALUE, + CHANGE => CHANGE, + SECOND_CHANGE => THIRD_CHANGE, + FIRST_EXPECTED_RESULT => FIRST_EXPECTED_RESULT, + SECOND_EXPECTED_RESULT => SECOND_EXPECTED_RESULT, + THIRD_EXPECTED_RESULT => THIRD_EXPECTED_RESULT, + FOURTH_EXPECTED_RESULT => FOURTH_EXPECTED_RESULT) ; + + FUNCTION INNER_VARIABLE RETURN SOME_TYPE IS + BEGIN + RETURN NEW_INNER.VARIABLE ; + END INNER_VARIABLE ; + + BEGIN -- OUTER + + SECOND_CHANGE (FIRST => VARIABLE, + RESULT => VARIABLE) ; + SECOND_CHANGE (FIRST => ANOTHER_VARIABLE, + RESULT => ANOTHER_VARIABLE) ; + + IF (VARIABLE /= FIFTH_EXPECTED_RESULT) OR + (ANOTHER_VARIABLE /= SIXTH_EXPECTED_RESULT) OR + (NEW_INNER.VARIABLE /= FIRST_EXPECTED_RESULT) THEN + REPORT.FAILED("ASSIGNED VALUES INCORRECT - BODY OF OUTER") ; + END IF; + + END OUTER ; + + PROCEDURE DOUBLE (THIS_VALUE : IN INTEGER; + GIVING_THIS_RESULT : OUT INTEGER) IS + BEGIN -- DOUBLE + GIVING_THIS_RESULT := 2 * THIS_VALUE ; + END DOUBLE ; + + PROCEDURE ADD_20 (TO_THIS_VALUE : IN INTEGER; + GIVING_THIS_RESULT : OUT INTEGER) IS + BEGIN -- ADD_20 + GIVING_THIS_RESULT := TO_THIS_VALUE + 20 ; + END ADD_20 ; + + PROCEDURE TIMES_FIVE (THIS_VALUE : IN INTEGER; + GIVING_THIS_RESULT : OUT INTEGER) IS + BEGIN -- TIMES_FIVE + GIVING_THIS_RESULT := 5 * THIS_VALUE ; + END TIMES_FIVE ; + +BEGIN -- CC3016C + + REPORT.TEST ("CC3016C" , "CHECK THAT AN INSTANCE OF A GENERIC PACKAGE " & + "MUST DECLARE A PACKAGE. CHECK THAT THE STATEMENTS IN AN " & + "INSTANTIATED GENERIC PACKAGE BODY ARE EXECUTED AFTER THE " & + "ELABORATION OF THE DECLARATIONS (IN SPEC AND IN BODY).") ; + + LOCAL_BLOCK: + + DECLARE + + PACKAGE NEW_OUTER IS NEW OUTER + (SOME_TYPE => INTEGER, + FIRST_INITIAL_VALUE => 7, + SECOND_INITIAL_VALUE => 11, + CHANGE => DOUBLE, + SECOND_CHANGE => ADD_20, + THIRD_CHANGE => TIMES_FIVE, + FIRST_EXPECTED_RESULT => 22, + SECOND_EXPECTED_RESULT => 22, + THIRD_EXPECTED_RESULT => 27, + FOURTH_EXPECTED_RESULT => 14, + FIFTH_EXPECTED_RESULT => 47, + SIXTH_EXPECTED_RESULT => 34) ; + + BEGIN -- LOCAL_BLOCK + + IF (NEW_OUTER.VARIABLE /= 47) OR + (NEW_OUTER.INNER_VARIABLE /= 22) THEN + REPORT.FAILED("ASSIGNED VALUES INCORRECT - " & + "BODY OF MAIN PROGRAM") ; + END IF; + + END LOCAL_BLOCK ; + + REPORT.RESULT; + +END CC3016C; diff --git a/gcc/testsuite/ada/acats/tests/cc/cc3016f.ada b/gcc/testsuite/ada/acats/tests/cc/cc3016f.ada new file mode 100644 index 000000000..9a1f099c1 --- /dev/null +++ b/gcc/testsuite/ada/acats/tests/cc/cc3016f.ada @@ -0,0 +1,187 @@ +-- CC3016F.ADA + +-- Grant of Unlimited Rights +-- +-- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687, +-- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained +-- unlimited rights in the software and documentation contained herein. +-- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making +-- this public release, the Government intends to confer upon all +-- recipients unlimited rights equal to those held by the Government. +-- These rights include rights to use, duplicate, release or disclose the +-- released technical data and computer software in whole or in part, in +-- any manner and for any purpose whatsoever, and to have or permit others +-- to do so. +-- +-- DISCLAIMER +-- +-- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR +-- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED +-- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE +-- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE +-- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A +-- PARTICULAR PURPOSE OF SAID MATERIAL. +--* +-- OFFICE, 3E 114, THE PENTAGON, WASHINGTON DC 20301-3081. + +-- OBJECTIVE: +-- CHECK THAT AN INSTANTIATED PACKAGE HAS THE PROPERTIES REQUIRED +-- OF A PACKAGE. + +-- CHECK THAT IF THE PARENT TYPE IN A DERIVED TYPE DEFINITION IS +-- A GENERIC FORMAL TYPE, THE OPERATIONS DECLARED FOR THE DERIVED +-- TYPE IN THE TEMPLATE ARE DETERMINED BY THE DECLARATION OF THE +-- FORMAL TYPE. THE OPERATIONS DECLARED FOR DERIVED TYPE IN THE +-- INSTANCE ARE DETERMINED BY THE ACTUAL TYPE DENOTED BY THE FORMAL +-- PARAMETER. SEE AI-00398. + +-- HISTORY: +-- DAS 8 OCT 90 INITIAL VERSION. +-- JRL 02/19/93 ADDED USE CLAUSES FOR INSTANCES TO ENSURE DIRECT +-- OPERATOR VISIBILITY. CHANGED NT4'LAST TO P4.NT4'LAST +-- IN ASSIGNMENT STATEMENT FOR P4.X IN EXAMPLE_4. +-- CORRECTED ABE ERRORS IN EXAMPLE_2 AND EXAMPLE_3. +-- CHANGED R3."+" FROM MULTIPLICATION TO SUBTRACTION TO +-- AVOID CONSTRAINT_ERROR. + +WITH REPORT; + +PROCEDURE CC3016F IS +BEGIN + REPORT.TEST ("CC3016F", "CHECK THAT IF THE PARENT TYPE IN A " & + "DERIVED TYPE DEFINITION IS A GENERIC " & + "FORMAL TYPE, THE OPERATIONS DECLARED " & + "FOR THE DERIVED TYPE IN THE TEMPLATE " & + "ARE DETERMINED BY THE DECLARATION OF " & + "THE FORMAL TYPE, AND THAT THE " & + "OPERATIONS DECLARED FOR THE DERIVED " & + "TYPE IN THE INSTANCE ARE DETERMINED BY " & + "THE ACTUAL TYPE DENOTED BY THE FORMAL " & + "PARAMETER (AI-00398)"); +EXAMPLE_2: + DECLARE + GENERIC + TYPE PRIV IS PRIVATE; + PACKAGE GP2 IS + TYPE NT2 IS NEW PRIV; + END GP2; + + PACKAGE R2 IS + TYPE T2 IS RANGE 1..10; + FUNCTION F RETURN T2; + END R2; + + PACKAGE P2 IS NEW GP2 (PRIV => R2.T2); + USE P2; + + XX1 : P2.NT2; + XX2 : P2.NT2; + XX3 : P2.NT2; + + PACKAGE BODY R2 IS + FUNCTION F RETURN T2 IS + BEGIN + RETURN T2'LAST; + END F; + END R2; + BEGIN + XX1 := 5; -- IMPLICIT CONVERSION FROM + -- UNIVERSAL INTEGER TO P2.NT2 + -- IN P2. + XX2 := XX1 + XX1; -- PREDEFINED "+" DECLARED FOR + -- P2.NT2. + XX3 := P2.F; -- FUNCTION F DERIVED WITH THE + -- INSTANCE. + + END EXAMPLE_2; + +EXAMPLE_3: + DECLARE + GENERIC + TYPE T3 IS RANGE <>; + PACKAGE GP3 IS + TYPE NT3 IS NEW T3; + X : NT3 := 5; + Y : NT3 := X + 3; -- USES PREDEFINED "+" EVEN IN + -- INSTANCES + END GP3; + + PACKAGE R3 IS + TYPE S IS RANGE 1..10; + FUNCTION "+" (LEFT : IN S; RIGHT : IN S) RETURN S; + END R3; + + PACKAGE P3 IS NEW GP3 ( T3 => R3.S ); + USE P3; + + Z : P3.NT3; + + PACKAGE BODY R3 IS + FUNCTION "+" (LEFT : IN S; RIGHT : IN S) RETURN S IS + BEGIN -- IMPLEMENT AS SUBTRACTION, NOT ADDITION + RETURN LEFT - RIGHT; + END "+"; + END R3; + BEGIN + Z := P3.X + 3; -- USES REDEFINED "+" + + IF ( P3.Y /= P3.NT3'(8) ) THEN + REPORT.FAILED ("PREDEFINED ""+"" NOT USED TO COMPUTE " & + "P3.Y"); + END IF; + + IF (Z /= P3.NT3'(2) ) THEN + REPORT.FAILED ("REDEFINED ""+"" NOT USED TO COMPUTE Z"); + END IF; + END EXAMPLE_3; + +EXAMPLE_4: + DECLARE + GENERIC + TYPE T4 IS LIMITED PRIVATE; + PACKAGE GP4 IS + TYPE NT4 IS NEW T4; + X : NT4; + END GP4; + + PACKAGE P4 IS NEW GP4 (BOOLEAN); + USE P4; + + BEGIN + P4.X := P4.NT4'LAST; + IF ( P4.X OR (NOT P4.X) ) THEN + REPORT.COMMENT ("P4.X CORRECTLY HAS A BOOLEAN TYPE"); + END IF; + END EXAMPLE_4; + +EXAMPLE_5: + DECLARE + GENERIC + TYPE T5 (D : POSITIVE) IS PRIVATE; + PACKAGE GP5 IS + TYPE NT5 IS NEW T5; + X : NT5 (D => 5); + Y : POSITIVE := X.D; -- REFERS TO DISCRIMINANT OF NT5 + END GP5; + + TYPE REC (A : POSITIVE) IS + RECORD + D : POSITIVE := 7; + END RECORD; + PACKAGE P5 IS NEW GP5 (T5 => REC); + -- P5.Y INITIALIZED WITH VALUE USING COMPONENT SELECTION + -- OPERATION FOR THE DISCRIMINANT, I.E. FOR PARENT TYPE + -- T5 WHICH DENOTES REC. + + W1 : POSITIVE := P5.X.D; -- VALUE IS 7 + W2 : POSITIVE := P5.X.A; -- VALUE IS 5 + W3 : POSITIVE := P5.Y; -- VALUE IS 5; + BEGIN + IF ( ( W1 /= 7 ) OR ( W2 /= 5 ) OR (W3 /= 5 ) ) THEN + REPORT.FAILED ("INCORRECT COMPONENT SELECTION"); + END IF; + END EXAMPLE_5; + + REPORT.RESULT; + +END CC3016F; diff --git a/gcc/testsuite/ada/acats/tests/cc/cc3016i.ada b/gcc/testsuite/ada/acats/tests/cc/cc3016i.ada new file mode 100644 index 000000000..933ec84b3 --- /dev/null +++ b/gcc/testsuite/ada/acats/tests/cc/cc3016i.ada @@ -0,0 +1,78 @@ +-- CC3016I.ADA + +-- Grant of Unlimited Rights +-- +-- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687, +-- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained +-- unlimited rights in the software and documentation contained herein. +-- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making +-- this public release, the Government intends to confer upon all +-- recipients unlimited rights equal to those held by the Government. +-- These rights include rights to use, duplicate, release or disclose the +-- released technical data and computer software in whole or in part, in +-- any manner and for any purpose whatsoever, and to have or permit others +-- to do so. +-- +-- DISCLAIMER +-- +-- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR +-- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED +-- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF 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 INSTANTIATED PACKAGE HAS THE PROPERTIES REQUIRED +-- OF A PACKAGE. + +-- CHECK THAT IF THE DESIGNATED TYPE OF AN ACCESS TYPE IS A GENERIC +-- FORMAL TYPE, OR IS A TYPE DERIVED DIRECTLY OR INDIRECTLY FROM A +-- GENERIC FORMAL TYPE, THE OPERATIONS DECLARED FOR THE ACCESS TYPE +-- IN THE TEMPLATE ARE DETERMINED BY THE DECLARATION OF THE FORMAL +-- TYPE. THE OPERATIONS DECLARED FOR ACCESS TYPE IN THE INSTANCE +-- ARE DETERMINED BY THE ACTUAL TYPE DENOTED BY THE FORMAL PARAMETER. +-- SEE AI-00398. + +-- HISTORY: +-- DAS 8 OCT 90 INITIAL VERSION. + + +WITH REPORT; USE REPORT; + +PROCEDURE CC3016I IS +BEGIN + TEST("CC3016I", "CHECK THAT AN INSTANTIATED PACKAGE HAS THE " & + "PROPERTIES REQUIRED OF A PACKAGE."); + +EXAMPLE_5A: + DECLARE + GENERIC + TYPE T5A (D : POSITIVE) IS PRIVATE; + PACKAGE GP5A IS + TYPE NT5A IS NEW T5A; + X : NT5A (D => 5); + Y : POSITIVE := X.D; -- REFERS TO DISCRIMINANT OF NT5A + END GP5A; + + TYPE REC (A : POSITIVE) IS + RECORD + D : POSITIVE := 7; + END RECORD; + PACKAGE P5A IS NEW GP5A (T5A => REC); + -- P5A.Y INITIALIZED WITH VALUE USING COMPONENT SELECTION + -- OPERATION FOR THE DISCRIMINANT, I.E. FOR PARENT TYPE + -- T5A WHICH DENOTES REC. + + W1 : POSITIVE := P5A.X.D; -- VALUE IS 7 + W2 : POSITIVE := P5A.X.A; -- VALUE IS 5 + W3 : POSITIVE := P5A.Y; -- VALUE IS 5; + BEGIN + IF ( ( W1 /= 7 ) OR ( W2 /= 5 ) OR (W3 /= 5 ) ) THEN + FAILED ("INCORRECT COMPONENT SELECTION - ACCESS"); + END IF; + END EXAMPLE_5A; + + RESULT; + +END CC3016I; diff --git a/gcc/testsuite/ada/acats/tests/cc/cc3017b.ada b/gcc/testsuite/ada/acats/tests/cc/cc3017b.ada new file mode 100644 index 000000000..0f8fcfd6f --- /dev/null +++ b/gcc/testsuite/ada/acats/tests/cc/cc3017b.ada @@ -0,0 +1,470 @@ +-- CC3017B.ADA + +-- Grant of Unlimited Rights +-- +-- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687, +-- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained +-- unlimited rights in the software and documentation contained herein. +-- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making +-- this public release, the Government intends to confer upon all +-- recipients unlimited rights equal to those held by the Government. +-- These rights include rights to use, duplicate, release or disclose the +-- released technical data and computer software in whole or in part, in +-- any manner and for any purpose whatsoever, and to have or permit others +-- to do so. +-- +-- DISCLAIMER +-- +-- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR +-- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED +-- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF 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 INSTANCE OF A GENERIC PROCEDURE MUST DECLARE A +-- PROCEDURE AND THAT AN INSTANCE OF A GENERIC FUNCTION MUST +-- DECLARE A FUNCTION. CHECK THAT CONSTRAINT_ERROR IS NOT RAISED +-- IF THE DEFAULT VALUE FOR A FORMAL PARAMETER DOES NOT SATISFY +-- THE CONSTRAINTS OF THE SUBTYPE_INDICATION WHEN THE +-- DECLARATION IS ELABORATED, ONLY WHEN THE DEFAULT IS USED. + +-- SUBTESTS ARE: +-- (A) ARRAY PARAMETERS CONSTRAINED WITH NONSTATIC BOUNDS AND +-- INITIALIZED WITH A STATIC AGGREGATE. +-- (B) A SCALAR PARAMETER WITH NON-STATIC RANGE CONSTRAINTS +-- INITIALIZED WITH A STATIC VALUE. +-- (C) A RECORD PARAMETER WHOSE COMPONENTS HAVE NON-STATIC +-- CONSTRAINTS INITIALIZED WITH A STATIC AGGREGATE. +-- (D) AN ARRAY PARAMETER CONSTRAINED WITH STATIC BOUNDS ON SUB- +-- SCRIPTS AND NON-STATIC BOUNDS ON COMPONENTS, INITIALIZED +-- WITH A STATIC AGGREGATE. +-- (E) A RECORD PARAMETER WITH A NON-STATIC CONSTRAINT +-- INITIALIZED WITH A STATIC AGGREGATE. + +-- EDWARD V. BERARD, 7 AUGUST 1990 + +WITH REPORT; + +PROCEDURE CC3017B IS + +BEGIN + + REPORT.TEST ("CC3017B", "CHECK THAT AN INSTANCE OF A GENERIC " & + "PROCEDURE MUST DECLARE A PROCEDURE AND THAT AN " & + "INSTANCE OF A GENERIC FUNCTION MUST DECLARE A " & + "FUNCTION. CHECK THAT CONSTRAINT_ERROR IS NOT " & + "RAISED IF AN INITIALIZATION VALUE DOES NOT SATISFY " & + "CONSTRAINTS ON A FORMAL PARAMETER"); + + -------------------------------------------------- + + NONSTAT_ARRAY_PARMS: + + DECLARE + +-- (A) ARRAY PARAMETERS CONSTRAINED WITH NONSTATIC BOUNDS AND +-- INITIALIZED WITH A STATIC AGGREGATE. + + TYPE NUMBER IS RANGE 1 .. 100 ; + + GENERIC + + TYPE INTEGER_TYPE IS RANGE <> ; + LOWER : IN INTEGER_TYPE ; + UPPER : IN INTEGER_TYPE ; + + PROCEDURE PA (FIRST : IN INTEGER_TYPE ; + SECOND : IN INTEGER_TYPE) ; + + PROCEDURE PA (FIRST : IN INTEGER_TYPE ; + SECOND : IN INTEGER_TYPE) IS + + TYPE A1 IS ARRAY (INTEGER_TYPE RANGE LOWER .. FIRST, + INTEGER_TYPE RANGE LOWER .. SECOND) + OF INTEGER_TYPE; + + PROCEDURE PA1 (A : A1 := ((LOWER,UPPER),(UPPER,UPPER))) + IS + BEGIN + REPORT.FAILED ("BODY OF PA1 EXECUTED"); + EXCEPTION + WHEN OTHERS => + REPORT.FAILED ("EXCEPTION RAISED IN PA1"); + END PA1; + + BEGIN -- PA + PA1; + EXCEPTION + WHEN CONSTRAINT_ERROR => + NULL; + WHEN OTHERS => + REPORT.FAILED ("WRONG EXCEPTION RAISED - PA1"); + END PA; + + PROCEDURE NEW_PA IS NEW PA (INTEGER_TYPE => NUMBER, + LOWER => 1, + UPPER => 50) ; + + BEGIN -- NONSTAT_ARRAY_PARMS + + NEW_PA (FIRST => NUMBER (25), + SECOND => NUMBER (75)); + + EXCEPTION + WHEN OTHERS => + REPORT.FAILED ("EXCEPTION RAISED IN CALL TO NEW_PA"); + + END NONSTAT_ARRAY_PARMS ; + + -------------------------------------------------- + + SCALAR_NON_STATIC: + + DECLARE + +-- (B) A SCALAR PARAMETER WITH NON-STATIC RANGE CONSTRAINTS +-- INITIALIZED WITH A STATIC VALUE. + + TYPE NUMBER IS RANGE 1 .. 100 ; + + GENERIC + + TYPE INTEGER_TYPE IS RANGE <> ; + STATIC_VALUE : IN INTEGER_TYPE ; + + PROCEDURE PB (LOWER : IN INTEGER_TYPE ; + UPPER : IN INTEGER_TYPE) ; + + PROCEDURE PB (LOWER : IN INTEGER_TYPE ; + UPPER : IN INTEGER_TYPE) IS + + SUBTYPE INT IS INTEGER_TYPE RANGE LOWER .. UPPER ; + + PROCEDURE PB1 (I : INT := STATIC_VALUE) IS + BEGIN -- PB1 + REPORT.FAILED ("BODY OF PB1 EXECUTED"); + EXCEPTION + WHEN OTHERS => + REPORT.FAILED ("EXCEPTION RAISED IN PB1"); + END PB1; + + BEGIN -- PB + PB1; + EXCEPTION + WHEN CONSTRAINT_ERROR => + NULL; + WHEN OTHERS => + REPORT.FAILED ("WRONG EXCEPTION RAISED - PB1"); + END PB; + + PROCEDURE NEW_PB IS NEW PB (INTEGER_TYPE => NUMBER, + STATIC_VALUE => 20) ; + + BEGIN -- SCALAR_NON_STATIC + + NEW_PB (LOWER => NUMBER (25), + UPPER => NUMBER (75)); + + EXCEPTION + WHEN OTHERS => + REPORT.FAILED ("EXCEPTION RAISED IN CALL TO NEW_PB"); + END SCALAR_NON_STATIC ; + + -------------------------------------------------- + + REC_NON_STAT_COMPS: + + DECLARE + +-- (C) A RECORD PARAMETER WHOSE COMPONENTS HAVE NON-STATIC +-- CONSTRAINTS INITIALIZED WITH A STATIC AGGREGATE. + + TYPE NUMBER IS RANGE 1 .. 100 ; + + GENERIC + + TYPE INTEGER_TYPE IS RANGE <> ; + F_STATIC_VALUE : IN INTEGER_TYPE ; + S_STATIC_VALUE : IN INTEGER_TYPE ; + T_STATIC_VALUE : IN INTEGER_TYPE ; + L_STATIC_VALUE : IN INTEGER_TYPE ; + + PROCEDURE PC (LOWER : IN INTEGER_TYPE ; + UPPER : IN INTEGER_TYPE) ; + + PROCEDURE PC (LOWER : IN INTEGER_TYPE ; + UPPER : IN INTEGER_TYPE) IS + + SUBTYPE SUBINTEGER_TYPE IS INTEGER_TYPE + RANGE LOWER .. UPPER ; + TYPE AR1 IS ARRAY (INTEGER RANGE 1..3) OF + SUBINTEGER_TYPE ; + TYPE REC IS + RECORD + FIRST : SUBINTEGER_TYPE ; + SECOND : AR1 ; + END RECORD; + + PROCEDURE PC1 (R : REC := (F_STATIC_VALUE, + (S_STATIC_VALUE, + T_STATIC_VALUE, + L_STATIC_VALUE))) IS + BEGIN -- PC1 + REPORT.FAILED ("BODY OF PC1 EXECUTED"); + EXCEPTION + WHEN OTHERS => + REPORT.FAILED ("EXCEPTION RAISED IN PC1"); + END PC1; + + BEGIN -- PC + PC1; + EXCEPTION + WHEN CONSTRAINT_ERROR => + NULL; + WHEN OTHERS => + REPORT.FAILED ("WRONG EXCEPTION RAISED - PC1"); + END PC; + + PROCEDURE NEW_PC IS NEW PC (INTEGER_TYPE => NUMBER, + F_STATIC_VALUE => 15, + S_STATIC_VALUE => 19, + T_STATIC_VALUE => 85, + L_STATIC_VALUE => 99) ; + + BEGIN -- REC_NON_STAT_COMPS + NEW_PC (LOWER => 20, + UPPER => 80); + EXCEPTION + WHEN OTHERS => + REPORT.FAILED ("EXCEPTION RAISED IN CALL TO NEW_PC"); + END REC_NON_STAT_COMPS ; + + -------------------------------------------------- + + FIRST_STATIC_ARRAY: + + DECLARE + +-- (D) AN ARRAY PARAMETER CONSTRAINED WITH STATIC BOUNDS ON SUB- +-- SCRIPTS AND NON-STATIC BOUNDS ON COMPONENTS, INITIALIZED +-- WITH A STATIC AGGREGATE. + + TYPE NUMBER IS RANGE 1 .. 100 ; + + GENERIC + + TYPE INTEGER_TYPE IS RANGE <> ; + F_STATIC_VALUE : IN INTEGER_TYPE ; + S_STATIC_VALUE : IN INTEGER_TYPE ; + T_STATIC_VALUE : IN INTEGER_TYPE ; + L_STATIC_VALUE : IN INTEGER_TYPE ; + A_STATIC_VALUE : IN INTEGER_TYPE ; + B_STATIC_VALUE : IN INTEGER_TYPE ; + C_STATIC_VALUE : IN INTEGER_TYPE ; + D_STATIC_VALUE : IN INTEGER_TYPE ; + + PROCEDURE P1D (LOWER : IN INTEGER_TYPE ; + UPPER : IN INTEGER_TYPE) ; + + PROCEDURE P1D (LOWER : IN INTEGER_TYPE ; + UPPER : IN INTEGER_TYPE) IS + + SUBTYPE SUBINTEGER_TYPE IS INTEGER_TYPE + RANGE LOWER .. UPPER ; + + TYPE A1 IS ARRAY (INTEGER_TYPE RANGE + F_STATIC_VALUE .. S_STATIC_VALUE, + INTEGER_TYPE RANGE + T_STATIC_VALUE .. L_STATIC_VALUE) + OF SUBINTEGER_TYPE ; + + PROCEDURE P1D1 (A : A1 := + ((A_STATIC_VALUE, B_STATIC_VALUE), + (C_STATIC_VALUE, D_STATIC_VALUE))) IS + BEGIN -- P1D1 + REPORT.FAILED ("BODY OF P1D1 EXECUTED"); + EXCEPTION + WHEN OTHERS => + REPORT.FAILED ("EXCEPTION RAISED IN P1D1"); + END P1D1; + + BEGIN -- P1D + P1D1 ; + EXCEPTION + WHEN CONSTRAINT_ERROR => + NULL; + WHEN OTHERS => + REPORT.FAILED ("WRONG EXCEPTION RAISED - P1D1"); + END P1D; + + PROCEDURE NEW_P1D IS NEW P1D (INTEGER_TYPE => NUMBER, + F_STATIC_VALUE => 21, + S_STATIC_VALUE => 37, + T_STATIC_VALUE => 67, + L_STATIC_VALUE => 79, + A_STATIC_VALUE => 11, + B_STATIC_VALUE => 88, + C_STATIC_VALUE => 87, + D_STATIC_VALUE => 13) ; + + BEGIN -- FIRST_STATIC_ARRAY + NEW_P1D (LOWER => 10, + UPPER => 90); + EXCEPTION + WHEN OTHERS => + REPORT.FAILED ("EXCEPTION RAISED IN CALL TO NEW_P1D"); + END FIRST_STATIC_ARRAY ; + + -------------------------------------------------- + + SECOND_STATIC_ARRAY: + + DECLARE + +-- (D) AN ARRAY PARAMETER CONSTRAINED WITH STATIC BOUNDS ON SUB- +-- SCRIPTS AND NON-STATIC BOUNDS ON COMPONENTS, INITIALIZED +-- WITH A STATIC AGGREGATE. + + TYPE NUMBER IS RANGE 1 .. 100 ; + + GENERIC + + TYPE INTEGER_TYPE IS RANGE <> ; + F_STATIC_VALUE : IN INTEGER_TYPE ; + S_STATIC_VALUE : IN INTEGER_TYPE ; + T_STATIC_VALUE : IN INTEGER_TYPE ; + L_STATIC_VALUE : IN INTEGER_TYPE ; + A_STATIC_VALUE : IN INTEGER_TYPE ; + B_STATIC_VALUE : IN INTEGER_TYPE ; + + PROCEDURE P2D (LOWER : IN INTEGER_TYPE ; + UPPER : IN INTEGER_TYPE) ; + + PROCEDURE P2D (LOWER : IN INTEGER_TYPE ; + UPPER : IN INTEGER_TYPE) IS + + SUBTYPE SUBINTEGER_TYPE IS INTEGER_TYPE + RANGE LOWER .. UPPER ; + + TYPE A1 IS ARRAY (INTEGER_TYPE RANGE + F_STATIC_VALUE .. S_STATIC_VALUE, + INTEGER_TYPE RANGE + T_STATIC_VALUE .. L_STATIC_VALUE) + OF SUBINTEGER_TYPE ; + + PROCEDURE P2D1 (A : A1 := + (F_STATIC_VALUE .. S_STATIC_VALUE => + (A_STATIC_VALUE, B_STATIC_VALUE))) IS + BEGIN -- P2D1 + REPORT.FAILED ("BODY OF P2D1 EXECUTED"); + EXCEPTION + WHEN OTHERS => + REPORT.FAILED ("EXCEPTION RAISED IN P2D1"); + END P2D1; + + BEGIN -- P2D + P2D1; + EXCEPTION + WHEN CONSTRAINT_ERROR => + NULL; + WHEN OTHERS => + REPORT.FAILED ("WRONG EXCEPTION RAISED - P2D1"); + END P2D; + + PROCEDURE NEW_P2D IS NEW P2D (INTEGER_TYPE => NUMBER, + F_STATIC_VALUE => 21, + S_STATIC_VALUE => 37, + T_STATIC_VALUE => 67, + L_STATIC_VALUE => 79, + A_STATIC_VALUE => 7, + B_STATIC_VALUE => 93) ; + + BEGIN -- SECOND_STATIC_ARRAY + NEW_P2D (LOWER => 5, + UPPER => 95); + EXCEPTION + WHEN OTHERS => + REPORT.FAILED ("EXCEPTION RAISED IN CALL TO NEW_P2D"); + END SECOND_STATIC_ARRAY ; + + -------------------------------------------------- + + REC_NON_STATIC_CONS: + + DECLARE + +-- (E) A RECORD PARAMETER WITH A NON-STATIC CONSTRAINT +-- INITIALIZED WITH A STATIC AGGREGATE. + + TYPE NUMBER IS RANGE 1 .. 100 ; + + GENERIC + + TYPE INTEGER_TYPE IS RANGE <> ; + F_STATIC_VALUE : IN INTEGER_TYPE ; + S_STATIC_VALUE : IN INTEGER_TYPE ; + T_STATIC_VALUE : IN INTEGER_TYPE ; + L_STATIC_VALUE : IN INTEGER_TYPE ; + D_STATIC_VALUE : IN INTEGER_TYPE ; + + PROCEDURE PE (LOWER : IN INTEGER_TYPE ; + UPPER : IN INTEGER_TYPE) ; + + PROCEDURE PE (LOWER : IN INTEGER_TYPE ; + UPPER : IN INTEGER_TYPE) IS + + SUBTYPE SUBINTEGER_TYPE IS INTEGER_TYPE + RANGE LOWER .. UPPER ; + TYPE AR1 IS ARRAY (INTEGER RANGE 1..3) OF + SUBINTEGER_TYPE ; + + TYPE REC (DISCRIM : SUBINTEGER_TYPE) IS + RECORD + FIRST : SUBINTEGER_TYPE ; + SECOND : AR1 ; + END RECORD ; + + SUBTYPE REC4 IS REC (LOWER) ; + + PROCEDURE PE1 (R : REC4 := (D_STATIC_VALUE, + F_STATIC_VALUE, + (S_STATIC_VALUE, + T_STATIC_VALUE, + L_STATIC_VALUE))) IS + BEGIN -- PE1 + REPORT.FAILED ("BODY OF PE1 EXECUTED"); + EXCEPTION + WHEN OTHERS => + REPORT.FAILED ("EXCEPTION RAISED IN PE1"); + END PE1; + + BEGIN -- PE + PE1; + EXCEPTION + WHEN CONSTRAINT_ERROR => + NULL; + WHEN OTHERS => + REPORT.FAILED ("WRONG EXCEPTION RAISED - PE1"); + END PE; + + PROCEDURE NEW_PE IS NEW PE (INTEGER_TYPE => NUMBER, + F_STATIC_VALUE => 37, + S_STATIC_VALUE => 21, + T_STATIC_VALUE => 67, + L_STATIC_VALUE => 79, + D_STATIC_VALUE => 44) ; + + BEGIN -- REC_NON_STATIC_CONS + NEW_PE (LOWER => 2, + UPPER => 99); + EXCEPTION + WHEN OTHERS => + REPORT.FAILED ("EXCEPTION RAISED IN CALL TO NEW_PE"); + END REC_NON_STATIC_CONS ; + + -------------------------------------------------- + + REPORT.RESULT; + +END CC3017B; diff --git a/gcc/testsuite/ada/acats/tests/cc/cc3017c.ada b/gcc/testsuite/ada/acats/tests/cc/cc3017c.ada new file mode 100644 index 000000000..d4649716f --- /dev/null +++ b/gcc/testsuite/ada/acats/tests/cc/cc3017c.ada @@ -0,0 +1,336 @@ +-- CC3017C.ADA + +-- Grant of Unlimited Rights +-- +-- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687, +-- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained +-- unlimited rights in the software and documentation contained herein. +-- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making +-- this public release, the Government intends to confer upon all +-- recipients unlimited rights equal to those held by the Government. +-- These rights include rights to use, duplicate, release or disclose the +-- released technical data and computer software in whole or in part, in +-- any manner and for any purpose whatsoever, and to have or permit others +-- to do so. +-- +-- DISCLAIMER +-- +-- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR +-- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED +-- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF 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 INSTANCE OF A GENERIC PROCEDURE MUST DECLARE A +-- PROCEDURE AND THAT AN INSTANCE OF A GENERIC FUNCTION MUST +-- DECLARE A FUNCTION. CHECK THAT SCALAR AND ACCESS PARAMETERS +-- ARE COPIED. +-- +-- SUBTESTS ARE: +-- (A) SCALAR PARAMETERS TO PROCEDURES. +-- (B) SCALAR PARAMETERS TO FUNCTIONS. +-- (C) ACCESS PARAMETERS TO PROCEDURES. +-- (D) ACCESS PARAMETERS TO FUNCTIONS. + +-- HISTORY: +-- EDWARD V. BERARD, 7 AUGUST 1990 +-- CJJ 10/16/90 ADJUSTED LINES THAT WERE TOO LONG; REFORMATTED +-- HEADER TO CONFORM TO ACVC STANDARDS. +-- + +WITH REPORT; +PROCEDURE CC3017C IS + +BEGIN + REPORT.TEST ("CC3017C", "CHECK THAT AN INSTANCE OF A GENERIC " & + "PROCEDURE MUST DECLARE A PROCEDURE AND THAT AN " & + "INSTANCE OF A GENERIC FUNCTION MUST DECLARE A " & + "FUNCTION. CHECK THAT SCALAR AND ACCESS PARAMETERS " & + "ARE COPIED"); + + -------------------------------------------------- + + SCALAR_TO_PROCS: + + DECLARE + +-- (A) SCALAR PARAMETERS TO PROCEDURES. + + TYPE NUMBER IS RANGE 0 .. 120 ; + VALUE : NUMBER ; + E : EXCEPTION ; + + GENERIC + + TYPE SCALAR_ITEM IS RANGE <> ; + + PROCEDURE P (P_IN : IN SCALAR_ITEM ; + P_OUT : OUT SCALAR_ITEM ; + P_IN_OUT : IN OUT SCALAR_ITEM) ; + + PROCEDURE P (P_IN : IN SCALAR_ITEM ; + P_OUT : OUT SCALAR_ITEM ; + P_IN_OUT : IN OUT SCALAR_ITEM) IS + + STORE : SCALAR_ITEM ; + + BEGIN -- P + + STORE := P_IN; -- SAVE VALUE OF P_IN AT PROC ENTRY. + + P_OUT := 10; + IF (P_IN /= STORE) THEN + REPORT.FAILED ("ASSIGNMENT TO SCALAR OUT " & + "PARAMETER CHANGES THE VALUE OF " & + "INPUT PARAMETER"); + STORE := P_IN; -- RESET STORE FOR NEXT CASE. + END IF; + + P_IN_OUT := P_IN_OUT + 100; + IF (P_IN /= STORE) THEN + REPORT.FAILED ("ASSIGNMENT TO SCALAR IN OUT " & + "PARAMETER CHANGES THE VALUE OF " & + "INPUT PARAMETER"); + STORE := P_IN; -- RESET STORE FOR NEXT CASE. + END IF; + + VALUE := VALUE + 1; + IF (P_IN /= STORE) THEN + REPORT.FAILED ("ASSIGNMENT TO SCALAR GLOBAL " & + "PARAMETER CHANGES THE VALUE OF " & + "INPUT PARAMETER"); + END IF; + + RAISE E; -- CHECK EXCEPTION HANDLING. + END P; + + PROCEDURE NEW_P IS NEW P (SCALAR_ITEM => NUMBER) ; + + BEGIN -- SCALAR_TO_PROCS + VALUE := 0; -- INITIALIZE VALUE SO VARIOUS CASES CAN BE DETECTED. + + NEW_P (P_IN => VALUE, + P_OUT => VALUE, + P_IN_OUT => VALUE); + + REPORT.FAILED ("EXCEPTION NOT RAISED - SCALARS TO PROCEDURES"); + EXCEPTION + WHEN E => + IF (VALUE /= 1) THEN + CASE VALUE IS + WHEN 11 => + REPORT.FAILED ("OUT ACTUAL SCALAR " & + "PARAMETER CHANGED GLOBAL VALUE"); + WHEN 101 => + REPORT.FAILED ("IN OUT ACTUAL SCALAR " & + "PARAMETER CHANGED GLOBAL VALUE"); + WHEN 111 => + REPORT.FAILED ("OUT AND IN OUT ACTUAL " & + "SCALAR PARAMETERS CHANGED " & + "GLOBAL VALUE"); + WHEN OTHERS => + REPORT.FAILED ("UNDETERMINED CHANGE TO " & + "GLOBAL VALUE"); + END CASE; + END IF; + WHEN OTHERS => + REPORT.FAILED ("WRONG EXCEPTION RAISED - SCALARS TO PROCEDURES"); + END SCALAR_TO_PROCS ; + + -------------------------------------------------- + + SCALAR_TO_FUNCS: + + DECLARE + +-- (B) SCALAR PARAMETERS TO FUNCTIONS. + + TYPE NUMBER IS RANGE 0 .. 101 ; + FIRST : NUMBER ; + SECOND : NUMBER ; + + GENERIC + + TYPE ITEM IS RANGE <> ; + + FUNCTION F (F_IN : IN ITEM) RETURN ITEM ; + + FUNCTION F (F_IN : IN ITEM) RETURN ITEM IS + + STORE : ITEM := F_IN; + + BEGIN -- F + + FIRST := FIRST + 1; + IF (F_IN /= STORE) THEN + REPORT.FAILED ("ASSIGNMENT TO SCALAR GLOBAL FUNCTION " & + "PARAMETER CHANGES THE VALUE OF " & + "INPUT PARAMETER"); + END IF; + + RETURN (100); + END F; + + FUNCTION NEW_F IS NEW F (ITEM => NUMBER) ; + + BEGIN -- SCALAR_TO_FUNCS + FIRST := 100 ; + SECOND := NEW_F (FIRST) ; + END SCALAR_TO_FUNCS ; + + -------------------------------------------------- + + ACCESS_TO_PROCS: + + DECLARE + +-- (C) ACCESS PARAMETERS TO PROCEDURES. + + TYPE MONTH_TYPE IS (JAN, FEB, MAR, APR, MAY, JUN, JUL, AUG, + SEP, OCT, NOV, DEC) ; + TYPE DAY_TYPE IS RANGE 1 .. 31 ; + TYPE YEAR_TYPE IS RANGE 1904 .. 2050 ; + TYPE DATE IS RECORD + MONTH : MONTH_TYPE ; + DAY : DAY_TYPE ; + YEAR : YEAR_TYPE ; + END RECORD ; + + TYPE DATE_ACCESS IS ACCESS DATE ; + DATE_POINTER : DATE_ACCESS ; + + E : EXCEPTION; + + GENERIC + + TYPE ITEM IS PRIVATE ; + TYPE ACCESS_ITEM IS ACCESS ITEM ; + + PROCEDURE P (P_IN : IN ACCESS_ITEM ; + P_OUT : OUT ACCESS_ITEM ; + P_IN_OUT : IN OUT ACCESS_ITEM) ; + + PROCEDURE P (P_IN : IN ACCESS_ITEM ; + P_OUT : OUT ACCESS_ITEM ; + P_IN_OUT : IN OUT ACCESS_ITEM) IS + + STORE : ACCESS_ITEM ; + + BEGIN -- P + + STORE := P_IN ; -- SAVE VALUE OF P_IN AT PROC ENTRY. + + DATE_POINTER := NEW DATE'(YEAR => 1990, + DAY => 7, + MONTH => AUG) ; + IF (P_IN /= STORE) THEN + REPORT.FAILED ("ASSIGNMENT TO ACCESS GLOBAL " & + "PARAMETER CHANGES THE VALUE OF " & + "INPUT PARAMETER"); + STORE := P_IN; -- RESET STORE FOR NEXT CASE. + END IF; + + P_OUT := NEW ITEM ; + IF (P_IN /= STORE) THEN + REPORT.FAILED ("ASSIGNMENT TO ACCESS OUT " & + "PARAMETER CHANGES THE VALUE OF " & + "INPUT PARAMETER"); + STORE := P_IN; -- RESET STORE FOR NEXT CASE. + END IF; + + P_IN_OUT := NEW ITEM ; + IF (P_IN /= STORE) THEN + REPORT.FAILED ("ASSIGNMENT TO ACCESS IN OUT " & + "PARAMETER CHANGES THE VALUE OF " & + "INPUT PARAMETER"); + END IF; + + RAISE E; -- CHECK EXCEPTION HANDLING. + END P ; + + PROCEDURE NEW_P IS NEW P (ITEM => DATE, + ACCESS_ITEM => DATE_ACCESS) ; + + BEGIN -- ACCESS_TO_PROCS + DATE_POINTER := NEW DATE'(MONTH => DEC, + DAY => 25, + YEAR => 2000) ; + + NEW_P (P_IN => DATE_POINTER, + P_OUT => DATE_POINTER, + P_IN_OUT => DATE_POINTER) ; + + REPORT.FAILED ("EXCEPTION NOT RAISED - ACCESS TO PROCEDURES"); + EXCEPTION + WHEN E => + IF (DATE_POINTER.ALL /= (AUG, 7, 1990)) THEN + REPORT.FAILED ("OUT OR IN OUT ACTUAL PROCEDURE " & + "PARAMETER VALUE CHANGED DESPITE " & + "RAISED EXCEPTION"); + END IF; + WHEN OTHERS => + REPORT.FAILED ("WRONG EXCEPTION RAISED - ACCESS TO PROCEDURES"); + END ACCESS_TO_PROCS ; + + -------------------------------------------------- + + ACCESS_TO_FUNCS: + + DECLARE + +-- (D) ACCESS PARAMETERS TO FUNCTIONS. + + TYPE MONTH_TYPE IS (JAN, FEB, MAR, APR, MAY, JUN, JUL, AUG, + SEP, OCT, NOV, DEC) ; + TYPE DAY_TYPE IS RANGE 1 .. 31 ; + TYPE YEAR_TYPE IS RANGE 1904 .. 2050 ; + TYPE DATE IS RECORD + MONTH : MONTH_TYPE ; + DAY : DAY_TYPE ; + YEAR : YEAR_TYPE ; + END RECORD ; + + TYPE DATE_ACCESS IS ACCESS DATE ; + DATE_POINTER : DATE_ACCESS ; + NEXT_DATE : DATE_ACCESS ; + + GENERIC + + TYPE ITEM IS PRIVATE ; + TYPE ACCESS_ITEM IS ACCESS ITEM ; + + FUNCTION F (F_IN : IN ACCESS_ITEM) RETURN ACCESS_ITEM ; + + FUNCTION F (F_IN : IN ACCESS_ITEM) RETURN ACCESS_ITEM IS + + STORE : ACCESS_ITEM := F_IN ; + + BEGIN -- F + + DATE_POINTER := NEW DATE'(YEAR => 1990, + DAY => 7, + MONTH => AUG) ; + IF (F_IN /= STORE) THEN + REPORT.FAILED ("ASSIGNMENT TO ACCESS GLOBAL FUNCTION " & + "PARAMETER CHANGES THE VALUE OF " & + "INPUT PARAMETER"); + END IF; + + RETURN (NULL); + END F ; + + FUNCTION NEW_F IS NEW F (ITEM => DATE, + ACCESS_ITEM => DATE_ACCESS) ; + + BEGIN -- ACCESS_TO_FUNCS + DATE_POINTER := NULL ; + NEXT_DATE := NEW_F(F_IN => DATE_POINTER) ; + END ACCESS_TO_FUNCS ; + + -------------------------------------------------- + + REPORT.RESULT; + +END CC3017C; diff --git a/gcc/testsuite/ada/acats/tests/cc/cc3019a.ada b/gcc/testsuite/ada/acats/tests/cc/cc3019a.ada new file mode 100644 index 000000000..3f5e84e60 --- /dev/null +++ b/gcc/testsuite/ada/acats/tests/cc/cc3019a.ada @@ -0,0 +1,173 @@ +-- CC3019A.ADA + +-- Grant of Unlimited Rights +-- +-- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687, +-- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained +-- unlimited rights in the software and documentation contained herein. +-- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making +-- this public release, the Government intends to confer upon all +-- recipients unlimited rights equal to those held by the Government. +-- These rights include rights to use, duplicate, release or disclose the +-- released technical data and computer software in whole or in part, in +-- any manner and for any purpose whatsoever, and to have or permit others +-- to do so. +-- +-- DISCLAIMER +-- +-- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR +-- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED +-- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF 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 INSTANTIATIONS OF NESTED GENERIC UNITS ARE PROCESSED +-- CORRECTLY. + +-- JBG 11/6/85 + +GENERIC + TYPE ELEMENT_TYPE IS PRIVATE; +PACKAGE CC3019A_QUEUES IS + + TYPE QUEUE_TYPE IS PRIVATE; + + PROCEDURE ADD (TO_Q : IN OUT QUEUE_TYPE; + VALUE : ELEMENT_TYPE); + + GENERIC + WITH PROCEDURE APPLY (VAL : ELEMENT_TYPE); + PROCEDURE ITERATOR (TO_Q : QUEUE_TYPE); + +PRIVATE + + TYPE CONTENTS_TYPE IS ARRAY (1..3) OF ELEMENT_TYPE; + TYPE QUEUE_TYPE IS + RECORD + CONTENTS : CONTENTS_TYPE; + SIZE : NATURAL := 0; + END RECORD; + +END CC3019A_QUEUES; + +PACKAGE BODY CC3019A_QUEUES IS + + PROCEDURE ADD (TO_Q : IN OUT QUEUE_TYPE; + VALUE : ELEMENT_TYPE) IS + BEGIN + TO_Q.SIZE := TO_Q.SIZE + 1; + TO_Q.CONTENTS(TO_Q.SIZE) := VALUE; + END ADD; + +-- GENERIC +-- WITH PROCEDURE APPLY (VAL : ELEMENT_TYPE); + PROCEDURE ITERATOR (TO_Q : QUEUE_TYPE) IS + BEGIN + FOR I IN TO_Q.CONTENTS'FIRST .. TO_Q.SIZE LOOP + APPLY (TO_Q.CONTENTS(I)); + END LOOP; + END ITERATOR; + +END CC3019A_QUEUES; + +WITH REPORT; USE REPORT; +WITH CC3019A_QUEUES; +PROCEDURE CC3019A IS + + SUBTYPE STR6 IS STRING (1..6); + + TYPE STR6_ARR IS ARRAY (1..3) OF STR6; + STR6_VALS : STR6_ARR := ("111111", "222222", + IDENT_STR("333333")); + CUR_STR_INDEX : NATURAL := 1; + + TYPE INT_ARR IS ARRAY (1..3) OF INTEGER; + INT_VALS : INT_ARR := (-1, 3, IDENT_INT(3)); + CUR_INT_INDEX : NATURAL := 1; + +-- THIS PROCEDURE IS CALLED ONCE FOR EACH ELEMENT OF THE QUEUE +-- + PROCEDURE CHECK_STR (VAL : STR6) IS + BEGIN + IF VAL /= STR6_VALS(CUR_STR_INDEX) THEN + FAILED ("STR6 ITERATOR FOR INDEX =" & + INTEGER'IMAGE(CUR_STR_INDEX) & " WITH VALUE " & + """" & VAL & """"); + END IF; + CUR_STR_INDEX := CUR_STR_INDEX + 1; + EXCEPTION + WHEN CONSTRAINT_ERROR => + FAILED ("STR6 - CONSTRAINT_ERROR RAISED"); + WHEN OTHERS => + FAILED ("STR6 - UNEXPECTED EXCEPTION"); + END CHECK_STR; + + PROCEDURE CHECK_INT (VAL : INTEGER) IS + BEGIN + IF VAL /= INT_VALS(CUR_INT_INDEX) THEN + FAILED ("INTEGER ITERATOR FOR INDEX =" & + INTEGER'IMAGE(CUR_INT_INDEX) & " WITH VALUE " & + """" & INTEGER'IMAGE(VAL) & """"); + END IF; + CUR_INT_INDEX := CUR_INT_INDEX + 1; + EXCEPTION + WHEN CONSTRAINT_ERROR => + FAILED ("INTEGER - CONSTRAINT_ERROR RAISED"); + WHEN OTHERS => + FAILED ("INTEGER - UNEXPECTED EXCEPTION"); + END CHECK_INT; + + PACKAGE STR6_QUEUE IS NEW CC3019A_QUEUES (STR6); + USE STR6_QUEUE; + + PACKAGE INT_QUEUE IS NEW CC3019A_QUEUES (INTEGER); + USE INT_QUEUE; + +BEGIN + + TEST ("CC3019A", "CHECK NESTED GENERICS - ITERATORS"); + + DECLARE + Q1 : STR6_QUEUE.QUEUE_TYPE; + + PROCEDURE CHK_STR IS NEW STR6_QUEUE.ITERATOR (CHECK_STR); + + BEGIN + + ADD (Q1, "111111"); + ADD (Q1, "222222"); + ADD (Q1, "333333"); + + CUR_STR_INDEX := 1; + CHK_STR (Q1); + + EXCEPTION + WHEN OTHERS => + FAILED ("UNEXPECTED EXCEPTION - Q1"); + END; + +-- REPEAT FOR INTEGERS + + DECLARE + Q2 : INT_QUEUE.QUEUE_TYPE; + + PROCEDURE CHK_INT IS NEW INT_QUEUE.ITERATOR (CHECK_INT); + + BEGIN + + ADD (Q2, -1); + ADD (Q2, 3); + ADD (Q2, 3); + + CUR_INT_INDEX := 1; + CHK_INT (Q2); + + EXCEPTION + WHEN OTHERS => + FAILED ("UNEXPECTED EXCEPTION - Q2"); + END; + + RESULT; + +END CC3019A; diff --git a/gcc/testsuite/ada/acats/tests/cc/cc3019b0.ada b/gcc/testsuite/ada/acats/tests/cc/cc3019b0.ada new file mode 100644 index 000000000..b7a7a9d4e --- /dev/null +++ b/gcc/testsuite/ada/acats/tests/cc/cc3019b0.ada @@ -0,0 +1,191 @@ +-- CC3019B0.ADA + +-- Grant of Unlimited Rights +-- +-- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687, +-- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained +-- unlimited rights in the software and documentation contained herein. +-- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making +-- this public release, the Government intends to confer upon all +-- recipients unlimited rights equal to those held by the Government. +-- These rights include rights to use, duplicate, release or disclose the +-- released technical data and computer software in whole or in part, in +-- any manner and for any purpose whatsoever, and to have or permit others +-- to do so. +-- +-- DISCLAIMER +-- +-- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR +-- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED +-- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE +-- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE +-- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A +-- PARTICULAR PURPOSE OF SAID MATERIAL. +--* +-- THIS IS GENERIC PACKAGE WHICH IS USED TO CHECK THE LEVEL OF +-- NESTED GENERICS SUPPORTED BY AN IMPLEMENTATION. +-- +-- HISTORY: +-- EDWARD V. BERARD, 31 AUGUST 1990 + +GENERIC + + TYPE ELEMENT IS LIMITED PRIVATE ; + + WITH PROCEDURE ASSIGN (SOURCE : IN OUT ELEMENT ; + DESTINATION : IN OUT ELEMENT) ; + + WITH FUNCTION "=" (LEFT : IN ELEMENT ; + RIGHT : IN ELEMENT) RETURN BOOLEAN ; + +PACKAGE CC3019B0_LIST_CLASS IS + + TYPE LIST IS LIMITED PRIVATE ; + + OVERFLOW : EXCEPTION ; + UNDERFLOW : EXCEPTION ; + + PROCEDURE ADD (THIS_ELEMENT : IN OUT ELEMENT ; + TO_THIS_LIST : IN OUT LIST) ; + + PROCEDURE DELETE (THIS_ELEMENT : IN OUT ELEMENT ; + FROM_THIS_LIST : IN OUT LIST) ; + + PROCEDURE COPY (THIS_LIST : IN OUT LIST ; + TO_THIS_LIST : IN OUT LIST) ; + + PROCEDURE CLEAR (THIS_LIST : IN OUT LIST) ; + + GENERIC + + WITH PROCEDURE PROCESS (THIS_ELEMENT : IN ELEMENT ; + CONTINUE : OUT BOOLEAN) ; + + PROCEDURE ITERATE (OVER_THIS_LIST : IN LIST) ; + + FUNCTION NUMBER_OF_ELEMENTS (IN_THIS_LIST : IN LIST) + RETURN NATURAL ; + + FUNCTION "=" (LEFT : IN LIST ; + RIGHT : IN LIST) RETURN BOOLEAN ; + +PRIVATE + + TYPE LIST_TABLE IS ARRAY (POSITIVE RANGE 1 .. 10) OF ELEMENT ; + + TYPE LIST IS RECORD + LENGTH : NATURAL := 0 ; + ACTUAL_LIST : LIST_TABLE ; + END RECORD ; + +END CC3019B0_LIST_CLASS ; + +PACKAGE BODY CC3019B0_LIST_CLASS IS + + PROCEDURE ADD (THIS_ELEMENT : IN OUT ELEMENT ; + TO_THIS_LIST : IN OUT LIST) IS + + BEGIN -- ADD + + IF TO_THIS_LIST.LENGTH >= 10 THEN + RAISE OVERFLOW ; + ELSE + TO_THIS_LIST.LENGTH := TO_THIS_LIST.LENGTH + 1 ; + ASSIGN ( + SOURCE => THIS_ELEMENT, + DESTINATION => + TO_THIS_LIST.ACTUAL_LIST (TO_THIS_LIST.LENGTH)); + END IF ; + + END ADD ; + + PROCEDURE DELETE (THIS_ELEMENT : IN OUT ELEMENT ; + FROM_THIS_LIST : IN OUT LIST) IS + + BEGIN -- DELETE + + IF FROM_THIS_LIST.LENGTH <= 0 THEN + RAISE UNDERFLOW ; + ELSE + ASSIGN ( + SOURCE => + FROM_THIS_LIST.ACTUAL_LIST(FROM_THIS_LIST.LENGTH), + DESTINATION => THIS_ELEMENT) ; + FROM_THIS_LIST.LENGTH := FROM_THIS_LIST.LENGTH - 1 ; + END IF ; + + END DELETE ; + + PROCEDURE COPY (THIS_LIST : IN OUT LIST ; + TO_THIS_LIST : IN OUT LIST) IS + + BEGIN -- COPY + + TO_THIS_LIST.LENGTH := THIS_LIST.LENGTH ; + FOR INDEX IN TO_THIS_LIST.ACTUAL_LIST'RANGE LOOP + ASSIGN ( + SOURCE => THIS_LIST.ACTUAL_LIST (INDEX), + DESTINATION => TO_THIS_LIST.ACTUAL_LIST (INDEX)) ; + END LOOP ; + + END COPY ; + + PROCEDURE CLEAR (THIS_LIST : IN OUT LIST) IS + + BEGIN -- CLEAR + + THIS_LIST.LENGTH := 0 ; + + END CLEAR ; + + PROCEDURE ITERATE (OVER_THIS_LIST : IN LIST) IS + + CONTINUE : BOOLEAN := TRUE ; + FINISHED : NATURAL := 0 ; + + BEGIN -- ITERATE + + WHILE (CONTINUE = TRUE) AND (FINISHED < OVER_THIS_LIST.LENGTH) + LOOP + FINISHED := FINISHED + 1 ; + PROCESS (THIS_ELEMENT => + OVER_THIS_LIST.ACTUAL_LIST (FINISHED), + CONTINUE => CONTINUE) ; + END LOOP ; + + END ITERATE ; + + FUNCTION NUMBER_OF_ELEMENTS (IN_THIS_LIST : IN LIST) + RETURN NATURAL IS + + BEGIN -- NUMBER_OF_ELEMENTS + + RETURN IN_THIS_LIST.LENGTH ; + + END NUMBER_OF_ELEMENTS ; + + FUNCTION "=" (LEFT : IN LIST ; + RIGHT : IN LIST) RETURN BOOLEAN IS + + RESULT : BOOLEAN := TRUE ; + INDEX : NATURAL := 0 ; + + BEGIN -- "=" + + IF LEFT.LENGTH /= RIGHT.LENGTH THEN + RESULT := FALSE ; + ELSE + WHILE (INDEX < LEFT.LENGTH) AND RESULT LOOP + INDEX := INDEX + 1 ; + IF LEFT.ACTUAL_LIST (INDEX) /= + RIGHT.ACTUAL_LIST (INDEX) THEN + RESULT := FALSE ; + END IF ; + END LOOP ; + END IF ; + + RETURN RESULT ; + + END "=" ; + +END CC3019B0_LIST_CLASS ; diff --git a/gcc/testsuite/ada/acats/tests/cc/cc3019b1.ada b/gcc/testsuite/ada/acats/tests/cc/cc3019b1.ada new file mode 100644 index 000000000..15dcb1370 --- /dev/null +++ b/gcc/testsuite/ada/acats/tests/cc/cc3019b1.ada @@ -0,0 +1,174 @@ +-- CC3019B1.ADA + +-- Grant of Unlimited Rights +-- +-- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687, +-- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained +-- unlimited rights in the software and documentation contained herein. +-- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making +-- this public release, the Government intends to confer upon all +-- recipients unlimited rights equal to those held by the Government. +-- These rights include rights to use, duplicate, release or disclose the +-- released technical data and computer software in whole or in part, in +-- any manner and for any purpose whatsoever, and to have or permit others +-- to do so. +-- +-- DISCLAIMER +-- +-- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR +-- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED +-- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE +-- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE +-- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A +-- PARTICULAR PURPOSE OF SAID MATERIAL. +--* +-- THIS IS GENERIC PACKAGE WHICH IS USED TO CHECK THE LEVEL OF +-- NESTED GENERICS SUPPORTED BY AN IMPLEMENTATION. IT IS USED +-- BY THE MAIN PROCEDURE, I.E., CC3019B2M.ADA. +-- +-- *** THIS FILE MUST BE COMPILED AFTER CC3019B0.ADA HAS BEEN +-- *** COMPILED. +-- +-- HISTORY: +-- EDWARD V. BERARD, 31 AUGUST 1990 + +WITH CC3019B0_LIST_CLASS ; + +GENERIC + + TYPE ELEMENT IS LIMITED PRIVATE ; + + WITH PROCEDURE ASSIGN (SOURCE : IN OUT ELEMENT ; + DESTINATION : IN OUT ELEMENT) ; + + WITH FUNCTION "=" (LEFT : IN ELEMENT ; + RIGHT : IN ELEMENT) RETURN BOOLEAN ; + +PACKAGE CC3019B1_STACK_CLASS IS + + TYPE STACK IS LIMITED PRIVATE ; + + OVERFLOW : EXCEPTION ; + UNDERFLOW : EXCEPTION ; + + PROCEDURE PUSH (THIS_ELEMENT : IN OUT ELEMENT ; + ON_TO_THIS_STACK : IN OUT STACK) ; + + PROCEDURE POP (THIS_ELEMENT : IN OUT ELEMENT ; + OFF_THIS_STACK : IN OUT STACK) ; + + PROCEDURE COPY (THIS_STACK : IN OUT STACK ; + TO_THIS_STACK : IN OUT STACK) ; + + PROCEDURE CLEAR (THIS_STACK : IN OUT STACK) ; + + GENERIC + + WITH PROCEDURE PROCESS (THIS_ELEMENT : IN ELEMENT ; + CONTINUE : OUT BOOLEAN) ; + + PROCEDURE ITERATE (OVER_THIS_STACK : IN STACK) ; + + FUNCTION NUMBER_OF_ELEMENTS (ON_THIS_STACK : IN STACK) + RETURN NATURAL ; + + FUNCTION "=" (LEFT : IN STACK ; + RIGHT : IN STACK) RETURN BOOLEAN ; + +PRIVATE + + PACKAGE NEW_LIST_CLASS IS + NEW CC3019B0_LIST_CLASS (ELEMENT => ELEMENT, + ASSIGN => ASSIGN, + "=" => "=") ; + + TYPE STACK IS NEW NEW_LIST_CLASS.LIST ; + +END CC3019B1_STACK_CLASS ; + +PACKAGE BODY CC3019B1_STACK_CLASS IS + + PROCEDURE PUSH (THIS_ELEMENT : IN OUT ELEMENT ; + ON_TO_THIS_STACK : IN OUT STACK) IS + + BEGIN -- PUSH + + NEW_LIST_CLASS.ADD ( + THIS_ELEMENT => THIS_ELEMENT, + TO_THIS_LIST => + NEW_LIST_CLASS.LIST (ON_TO_THIS_STACK)) ; + + EXCEPTION + + WHEN NEW_LIST_CLASS.OVERFLOW => RAISE OVERFLOW ; + + END PUSH ; + + PROCEDURE POP (THIS_ELEMENT : IN OUT ELEMENT ; + OFF_THIS_STACK : IN OUT STACK) IS + + BEGIN -- POP + + NEW_LIST_CLASS.DELETE ( + THIS_ELEMENT => THIS_ELEMENT, + FROM_THIS_LIST => + NEW_LIST_CLASS.LIST (OFF_THIS_STACK)) ; + + EXCEPTION + + WHEN NEW_LIST_CLASS.UNDERFLOW => RAISE UNDERFLOW ; + + END POP ; + + PROCEDURE COPY (THIS_STACK : IN OUT STACK ; + TO_THIS_STACK : IN OUT STACK) IS + + BEGIN -- COPY + + NEW_LIST_CLASS.COPY ( + THIS_LIST => NEW_LIST_CLASS.LIST (THIS_STACK), + TO_THIS_LIST => NEW_LIST_CLASS.LIST (TO_THIS_STACK)) ; + + END COPY ; + + PROCEDURE CLEAR (THIS_STACK : IN OUT STACK) IS + + BEGIN -- CLEAR + + NEW_LIST_CLASS.CLEAR (NEW_LIST_CLASS.LIST (THIS_STACK)) ; + + END CLEAR ; + + PROCEDURE ITERATE (OVER_THIS_STACK : IN STACK) IS + + PROCEDURE STACK_ITERATE IS NEW NEW_LIST_CLASS.ITERATE + (PROCESS => PROCESS) ; + + BEGIN -- ITERATE + + STACK_ITERATE (NEW_LIST_CLASS.LIST (OVER_THIS_STACK)) ; + + END ITERATE ; + + FUNCTION NUMBER_OF_ELEMENTS (ON_THIS_STACK : IN STACK) + RETURN NATURAL IS + + BEGIN -- NUMBER_OF_ELEMENTS + + RETURN NEW_LIST_CLASS.NUMBER_OF_ELEMENTS + (IN_THIS_LIST => NEW_LIST_CLASS.LIST (ON_THIS_STACK)) ; + + END NUMBER_OF_ELEMENTS ; + + FUNCTION "=" (LEFT : IN STACK ; + RIGHT : IN STACK) RETURN BOOLEAN IS + + BEGIN -- "=" + + RETURN NEW_LIST_CLASS."=" ( + LEFT => NEW_LIST_CLASS.LIST (LEFT), + RIGHT => NEW_LIST_CLASS.LIST (RIGHT)) ; + + END "=" ; + +END CC3019B1_STACK_CLASS ; diff --git a/gcc/testsuite/ada/acats/tests/cc/cc3019b2.ada b/gcc/testsuite/ada/acats/tests/cc/cc3019b2.ada new file mode 100644 index 000000000..52bf79ddc --- /dev/null +++ b/gcc/testsuite/ada/acats/tests/cc/cc3019b2.ada @@ -0,0 +1,300 @@ +-- CC3019B2M.ADA + +-- Grant of Unlimited Rights +-- +-- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687, +-- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained +-- unlimited rights in the software and documentation contained herein. +-- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making +-- this public release, the Government intends to confer upon all +-- recipients unlimited rights equal to those held by the Government. +-- These rights include rights to use, duplicate, release or disclose the +-- released technical data and computer software in whole or in part, in +-- any manner and for any purpose whatsoever, and to have or permit others +-- to do so. +-- +-- DISCLAIMER +-- +-- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR +-- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED +-- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF 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 INSTANTIATIONS OF UNITS WITHIN GENERIC UNITS, E.G., +-- TO SUPPORT ITERATORS. THIS TEST SPECIFICALLY CHECKS THAT A +-- NESTING LEVEL OF 2 IS SUPPORTED FOR GENERICS. +-- +-- *** THIS IS THE MAIN PROGRAM. IT MUST BE COMPILED AFTER THE +-- *** SOURCE CODE IN FILES CC3019B0.ADA AND CC3019B1.ADA HAVE +-- *** BEEN COMPILED. +-- +-- HISTORY: +-- EDWARD V. BERARD, 31 AUGUST 1990 + +WITH REPORT ; +WITH CC3019B1_STACK_CLASS ; + +PROCEDURE CC3019B2M IS + + TYPE MONTH_TYPE IS (JAN, FEB, MAR, APR, MAY, JUN, JUL, AUG, + SEP, OCT, NOV, DEC) ; + TYPE DAY_TYPE IS RANGE 1 .. 31 ; + TYPE YEAR_TYPE IS RANGE 1904 .. 2050 ; + TYPE DATE IS RECORD + MONTH : MONTH_TYPE ; + DAY : DAY_TYPE ; + YEAR : YEAR_TYPE ; + END RECORD ; + + STORE_DATE : DATE ; + + TODAY : DATE := (MONTH => AUG, + DAY => 31, + YEAR => 1990) ; + + FIRST_DATE : DATE := (MONTH => JUN, + DAY => 4, + YEAR => 1967) ; + + BIRTH_DATE : DATE := (MONTH => OCT, + DAY => 3, + YEAR => 1949) ; + + WALL_DATE : DATE := (MONTH => NOV, + DAY => 9, + YEAR => 1989) ; + + PROCEDURE ASSIGN (THE_VALUE_OF_THIS_DATE : IN OUT DATE ; + TO_THIS_DATE : IN OUT DATE) ; + + FUNCTION IS_EQUAL (LEFT : IN DATE ; + RIGHT : IN DATE) RETURN BOOLEAN ; + + PACKAGE DATE_STACK IS + NEW CC3019B1_STACK_CLASS (ELEMENT => DATE, + ASSIGN => ASSIGN, + "=" => IS_EQUAL) ; + + FIRST_DATE_STACK : DATE_STACK.STACK ; + SECOND_DATE_STACK : DATE_STACK.STACK ; + THIRD_DATE_STACK : DATE_STACK.STACK ; + + FUNCTION "=" (LEFT : IN DATE_STACK.STACK ; + RIGHT : IN DATE_STACK.STACK) RETURN BOOLEAN + RENAMES DATE_STACK."=" ; + + PROCEDURE ASSIGN (THE_VALUE_OF_THIS_DATE : IN OUT DATE ; + TO_THIS_DATE : IN OUT DATE) IS + + BEGIN -- ASSIGN + + TO_THIS_DATE := THE_VALUE_OF_THIS_DATE ; + + END ASSIGN ; + + FUNCTION IS_EQUAL (LEFT : IN DATE ; + RIGHT : IN DATE) RETURN BOOLEAN IS + + BEGIN -- IS_EQUAL + + RETURN (LEFT.MONTH = RIGHT.MONTH) AND + (LEFT.DAY = RIGHT.DAY) AND + (LEFT.YEAR = RIGHT.YEAR) ; + + END IS_EQUAL ; + +BEGIN -- CC3019B2M + + REPORT.TEST ("CC3019B2M", + "CHECK INSTANTIATIONS OF UNITS WITHIN GENERIC " & + "UNITS, E.G., TO SUPPORT ITERATORS. THIS TEST " & + "SPECIFICALLY CHECKS THAT A NESTING LEVEL OF " & + "2 IS SUPPORTED FOR GENERICS.") ; + + DATE_STACK.CLEAR (THIS_STACK => FIRST_DATE_STACK) ; + IF DATE_STACK.NUMBER_OF_ELEMENTS + (ON_THIS_STACK => FIRST_DATE_STACK) /= 0 THEN + REPORT.FAILED ( + "IMPROPER VALUE RETURNED FROM NUMBER_OF_ELEMENTS - 1") ; + END IF ; + + DATE_STACK.PUSH (THIS_ELEMENT => TODAY, + ON_TO_THIS_STACK => FIRST_DATE_STACK) ; + IF DATE_STACK.NUMBER_OF_ELEMENTS + (ON_THIS_STACK => FIRST_DATE_STACK) /= 1 THEN + REPORT.FAILED ( + "IMPROPER VALUE RETURNED FROM NUMBER_OF_ELEMENTS - 2") ; + END IF ; + + DATE_STACK.PUSH (THIS_ELEMENT => FIRST_DATE, + ON_TO_THIS_STACK => FIRST_DATE_STACK) ; + IF DATE_STACK.NUMBER_OF_ELEMENTS + (ON_THIS_STACK => FIRST_DATE_STACK) /= 2 THEN + REPORT.FAILED ( + "IMPROPER VALUE RETURNED FROM NUMBER_OF_ELEMENTS - 3") ; + END IF ; + + DATE_STACK.PUSH (THIS_ELEMENT => BIRTH_DATE, + ON_TO_THIS_STACK => FIRST_DATE_STACK) ; + IF DATE_STACK.NUMBER_OF_ELEMENTS + (ON_THIS_STACK => FIRST_DATE_STACK) /= 3 THEN + REPORT.FAILED ( + "IMPROPER VALUE RETURNED FROM NUMBER_OF_ELEMENTS - 4") ; + END IF ; + + DATE_STACK.POP (THIS_ELEMENT => STORE_DATE, + OFF_THIS_STACK => FIRST_DATE_STACK) ; + IF DATE_STACK.NUMBER_OF_ELEMENTS + (ON_THIS_STACK => FIRST_DATE_STACK) /= 2 THEN + REPORT.FAILED ( + "IMPROPER VALUE RETURNED FROM NUMBER_OF_ELEMENTS - 5") ; + END IF ; + + IF STORE_DATE /= BIRTH_DATE THEN + REPORT.FAILED ( + "IMPROPER VALUE REMOVED FROM STACK - 1") ; + END IF ; + + DATE_STACK.CLEAR (THIS_STACK => SECOND_DATE_STACK) ; + IF DATE_STACK.NUMBER_OF_ELEMENTS + (ON_THIS_STACK => SECOND_DATE_STACK) /= 0 THEN + REPORT.FAILED ( + "IMPROPER VALUE RETURNED FROM NUMBER_OF_ELEMENTS - 6") ; + END IF ; + + DATE_STACK.COPY (THIS_STACK => FIRST_DATE_STACK, + TO_THIS_STACK => SECOND_DATE_STACK) ; + + IF FIRST_DATE_STACK /= SECOND_DATE_STACK THEN + REPORT.FAILED ( + "PROBLEMS WITH COPY OR TEST FOR EQUALITY") ; + END IF ; + + DATE_STACK.POP (THIS_ELEMENT => STORE_DATE, + OFF_THIS_STACK => SECOND_DATE_STACK) ; + DATE_STACK.PUSH (THIS_ELEMENT => WALL_DATE, + ON_TO_THIS_STACK => SECOND_DATE_STACK) ; + IF FIRST_DATE_STACK = SECOND_DATE_STACK THEN + REPORT.FAILED ( + "PROBLEMS WITH POP OR TEST FOR EQUALITY") ; + END IF ; + + UNDERFLOW_EXCEPTION_TEST: + + BEGIN -- UNDERFLOW_EXCEPTION_TEST + + DATE_STACK.CLEAR (THIS_STACK => THIRD_DATE_STACK) ; + DATE_STACK.POP (THIS_ELEMENT => STORE_DATE, + OFF_THIS_STACK => THIRD_DATE_STACK) ; + REPORT.FAILED ("UNDERFLOW EXCEPTION NOT RAISED") ; + + EXCEPTION + + WHEN DATE_STACK.UNDERFLOW => NULL ; -- CORRECT EXCEPTION + -- RAISED + WHEN OTHERS => + REPORT.FAILED ("INCORRECT EXCEPTION RAISED IN " & + "UNDERFLOW EXCEPTION TEST") ; + + END UNDERFLOW_EXCEPTION_TEST ; + + OVERFLOW_EXCEPTION_TEST: + + BEGIN -- OVERFLOW_EXCEPTION_TEST + + DATE_STACK.CLEAR (THIS_STACK => THIRD_DATE_STACK) ; + FOR INDEX IN 1 .. 10 LOOP + DATE_STACK.PUSH ( THIS_ELEMENT => TODAY, + ON_TO_THIS_STACK => THIRD_DATE_STACK) ; + END LOOP ; + + DATE_STACK.PUSH (THIS_ELEMENT => TODAY, + ON_TO_THIS_STACK => THIRD_DATE_STACK) ; + REPORT.FAILED ("OVERFLOW EXCEPTION NOT RAISED") ; + + EXCEPTION + + WHEN DATE_STACK.OVERFLOW => NULL ; -- CORRECT EXCEPTION + -- RAISED + WHEN OTHERS => + REPORT.FAILED ("INCORRECT EXCEPTION RAISED IN " & + "OVERFLOW EXCEPTION TEST") ; + + END OVERFLOW_EXCEPTION_TEST ; + + LOCAL_BLOCK: + + DECLARE + + TYPE DATE_TABLE IS ARRAY (POSITIVE RANGE 1 .. 10) OF DATE ; + + FIRST_DATE_TABLE : DATE_TABLE ; + + TABLE_INDEX : POSITIVE := 1 ; + + PROCEDURE SHOW_DATES (THIS_DATE : IN DATE ; + CONTINUE : OUT BOOLEAN) ; + + PROCEDURE STORE_DATES (THIS_DATE : IN DATE ; + CONTINUE : OUT BOOLEAN) ; + + PROCEDURE SHOW_DATE_ITERATE IS NEW + DATE_STACK.ITERATE (PROCESS => SHOW_DATES) ; + + PROCEDURE STORE_DATE_ITERATE IS NEW + DATE_STACK.ITERATE (PROCESS => STORE_DATES) ; + + PROCEDURE SHOW_DATES (THIS_DATE : IN DATE ; + CONTINUE : OUT BOOLEAN) IS + BEGIN -- SHOW_DATES + + REPORT.COMMENT ("THE MONTH IS " & + MONTH_TYPE'IMAGE (THIS_DATE.MONTH)) ; + REPORT.COMMENT ("THE DAY IS " & + DAY_TYPE'IMAGE (THIS_DATE.DAY)) ; + REPORT.COMMENT ("THE YEAR IS " & + YEAR_TYPE'IMAGE (THIS_DATE.YEAR)) ; + + CONTINUE := TRUE ; + + END SHOW_DATES ; + + PROCEDURE STORE_DATES (THIS_DATE : IN DATE ; + CONTINUE : OUT BOOLEAN) IS + BEGIN -- STORE_DATES + + FIRST_DATE_TABLE (TABLE_INDEX) := THIS_DATE ; + TABLE_INDEX := TABLE_INDEX + 1 ; + + CONTINUE := TRUE ; + + END STORE_DATES ; + + BEGIN -- LOCAL_BLOCK + + REPORT.COMMENT ("CONTENTS OF THE FIRST STACK") ; + SHOW_DATE_ITERATE (OVER_THIS_STACK => FIRST_DATE_STACK) ; + + REPORT.COMMENT ("CONTENTS OF THE SECOND STACK") ; + SHOW_DATE_ITERATE (OVER_THIS_STACK => SECOND_DATE_STACK) ; + + STORE_DATE_ITERATE (OVER_THIS_STACK => FIRST_DATE_STACK) ; + IF (FIRST_DATE_TABLE (1) /= TODAY) OR + (FIRST_DATE_TABLE (2) /= FIRST_DATE) THEN + REPORT.FAILED ("PROBLEMS WITH ITERATION - 1") ; + END IF ; + + TABLE_INDEX := 1 ; + STORE_DATE_ITERATE (OVER_THIS_STACK => SECOND_DATE_STACK) ; + IF (FIRST_DATE_TABLE (1) /= TODAY) OR + (FIRST_DATE_TABLE (2) /= WALL_DATE) THEN + REPORT.FAILED ("PROBLEMS WITH ITERATION - 2") ; + END IF ; + + END LOCAL_BLOCK ; + + REPORT.RESULT ; + +END CC3019B2M ; diff --git a/gcc/testsuite/ada/acats/tests/cc/cc3019c0.ada b/gcc/testsuite/ada/acats/tests/cc/cc3019c0.ada new file mode 100644 index 000000000..d34ff79f0 --- /dev/null +++ b/gcc/testsuite/ada/acats/tests/cc/cc3019c0.ada @@ -0,0 +1,191 @@ +-- CC3019C0.ADA + +-- Grant of Unlimited Rights +-- +-- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687, +-- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained +-- unlimited rights in the software and documentation contained herein. +-- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making +-- this public release, the Government intends to confer upon all +-- recipients unlimited rights equal to those held by the Government. +-- These rights include rights to use, duplicate, release or disclose the +-- released technical data and computer software in whole or in part, in +-- any manner and for any purpose whatsoever, and to have or permit others +-- to do so. +-- +-- DISCLAIMER +-- +-- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR +-- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED +-- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF 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 +-- THIS IS GENERIC PACKAGE WHICH IS USED TO CHECK THE LEVEL OF +-- NESTED GENERICS SUPPORTED BY AN IMPLEMENTATION. +-- +-- HISTORY: +-- EDWARD V. BERARD, 31 AUGUST 1990 + +GENERIC + + TYPE ELEMENT IS LIMITED PRIVATE ; + + WITH PROCEDURE ASSIGN (SOURCE : IN OUT ELEMENT ; + DESTINATION : IN OUT ELEMENT) ; + + WITH FUNCTION "=" (LEFT : IN ELEMENT ; + RIGHT : IN ELEMENT) RETURN BOOLEAN ; + +PACKAGE CC3019C0_LIST_CLASS IS + + TYPE LIST IS LIMITED PRIVATE ; + + OVERFLOW : EXCEPTION ; + UNDERFLOW : EXCEPTION ; + + PROCEDURE ADD (THIS_ELEMENT : IN OUT ELEMENT ; + TO_THIS_LIST : IN OUT LIST) ; + + PROCEDURE DELETE (THIS_ELEMENT : IN OUT ELEMENT ; + FROM_THIS_LIST : IN OUT LIST) ; + + PROCEDURE COPY (THIS_LIST : IN OUT LIST ; + TO_THIS_LIST : IN OUT LIST) ; + + PROCEDURE CLEAR (THIS_LIST : IN OUT LIST) ; + + GENERIC + + WITH PROCEDURE PROCESS (THIS_ELEMENT : IN ELEMENT ; + CONTINUE : OUT BOOLEAN) ; + + PROCEDURE ITERATE (OVER_THIS_LIST : IN LIST) ; + + FUNCTION NUMBER_OF_ELEMENTS (IN_THIS_LIST : IN LIST) + RETURN NATURAL ; + + FUNCTION "=" (LEFT : IN LIST ; + RIGHT : IN LIST) RETURN BOOLEAN ; + +PRIVATE + + TYPE LIST_TABLE IS ARRAY (POSITIVE RANGE 1 .. 10) OF ELEMENT ; + + TYPE LIST IS RECORD + LENGTH : NATURAL := 0 ; + ACTUAL_LIST : LIST_TABLE ; + END RECORD ; + +END CC3019C0_LIST_CLASS ; + +PACKAGE BODY CC3019C0_LIST_CLASS IS + + PROCEDURE ADD (THIS_ELEMENT : IN OUT ELEMENT ; + TO_THIS_LIST : IN OUT LIST) IS + + BEGIN -- ADD + + IF TO_THIS_LIST.LENGTH >= 10 THEN + RAISE OVERFLOW ; + ELSE + TO_THIS_LIST.LENGTH := TO_THIS_LIST.LENGTH + 1 ; + ASSIGN ( + SOURCE => THIS_ELEMENT, + DESTINATION => + TO_THIS_LIST.ACTUAL_LIST(TO_THIS_LIST.LENGTH)); + END IF ; + + END ADD ; + + PROCEDURE DELETE (THIS_ELEMENT : IN OUT ELEMENT ; + FROM_THIS_LIST : IN OUT LIST) IS + + BEGIN -- DELETE + + IF FROM_THIS_LIST.LENGTH <= 0 THEN + RAISE UNDERFLOW ; + ELSE + ASSIGN ( + SOURCE => + FROM_THIS_LIST.ACTUAL_LIST(FROM_THIS_LIST.LENGTH), + DESTINATION => THIS_ELEMENT) ; + FROM_THIS_LIST.LENGTH := FROM_THIS_LIST.LENGTH - 1 ; + END IF ; + + END DELETE ; + + PROCEDURE COPY (THIS_LIST : IN OUT LIST ; + TO_THIS_LIST : IN OUT LIST) IS + + BEGIN -- COPY + + TO_THIS_LIST.LENGTH := THIS_LIST.LENGTH ; + FOR INDEX IN TO_THIS_LIST.ACTUAL_LIST'RANGE LOOP + ASSIGN (SOURCE => THIS_LIST.ACTUAL_LIST (INDEX), + DESTINATION => TO_THIS_LIST.ACTUAL_LIST (INDEX)); + END LOOP ; + + END COPY ; + + PROCEDURE CLEAR (THIS_LIST : IN OUT LIST) IS + + BEGIN -- CLEAR + + THIS_LIST.LENGTH := 0 ; + + END CLEAR ; + + PROCEDURE ITERATE (OVER_THIS_LIST : IN LIST) IS + + CONTINUE : BOOLEAN := TRUE ; + FINISHED : NATURAL := 0 ; + + BEGIN -- ITERATE + + WHILE (CONTINUE = TRUE) AND (FINISHED < OVER_THIS_LIST.LENGTH) + LOOP + FINISHED := FINISHED + 1 ; + PROCESS (THIS_ELEMENT => + OVER_THIS_LIST.ACTUAL_LIST (FINISHED), + CONTINUE => CONTINUE) ; + END LOOP ; + + END ITERATE ; + + FUNCTION NUMBER_OF_ELEMENTS (IN_THIS_LIST : IN LIST) + RETURN NATURAL IS + + BEGIN -- NUMBER_OF_ELEMENTS + + RETURN IN_THIS_LIST.LENGTH ; + + END NUMBER_OF_ELEMENTS ; + + FUNCTION "=" (LEFT : IN LIST ; + RIGHT : IN LIST) RETURN BOOLEAN IS + + RESULT : BOOLEAN := TRUE ; + INDEX : NATURAL := 0 ; + + BEGIN -- "=" + + IF LEFT.LENGTH /= RIGHT.LENGTH THEN + RESULT := FALSE ; + ELSE + WHILE (INDEX < LEFT.LENGTH) AND RESULT LOOP + INDEX := INDEX + 1 ; + IF LEFT.ACTUAL_LIST (INDEX) /= + RIGHT.ACTUAL_LIST (INDEX) THEN + RESULT := FALSE ; + END IF ; + END LOOP ; + END IF ; + + RETURN RESULT ; + + END "=" ; + +END CC3019C0_LIST_CLASS ; diff --git a/gcc/testsuite/ada/acats/tests/cc/cc3019c1.ada b/gcc/testsuite/ada/acats/tests/cc/cc3019c1.ada new file mode 100644 index 000000000..527c27f5a --- /dev/null +++ b/gcc/testsuite/ada/acats/tests/cc/cc3019c1.ada @@ -0,0 +1,331 @@ +-- CC3019C1.ADA + +-- Grant of Unlimited Rights +-- +-- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687, +-- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained +-- unlimited rights in the software and documentation contained herein. +-- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making +-- this public release, the Government intends to confer upon all +-- recipients unlimited rights equal to those held by the Government. +-- These rights include rights to use, duplicate, release or disclose the +-- released technical data and computer software in whole or in part, in +-- any manner and for any purpose whatsoever, and to have or permit others +-- to do so. +-- +-- DISCLAIMER +-- +-- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR +-- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED +-- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE +-- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE +-- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A +-- PARTICULAR PURPOSE OF SAID MATERIAL. +--* +-- THIS IS GENERIC PACKAGE WHICH IS USED TO CHECK THE LEVEL OF +-- NESTED GENERICS SUPPORTED BY AN IMPLEMENTATION. IT IS USED +-- BY MAIN PROCEDURE CC3019C2M.ADA. +-- +-- HISTORY: +-- EDWARD V. BERARD, 31 AUGUST 1990 + +WITH CC3019C0_LIST_CLASS ; + +GENERIC + + TYPE ELEMENT IS LIMITED PRIVATE ; + + WITH PROCEDURE ASSIGN (SOURCE : IN OUT ELEMENT ; + DESTINATION : IN OUT ELEMENT) ; + + WITH FUNCTION "=" (LEFT : IN ELEMENT ; + RIGHT : IN ELEMENT) RETURN BOOLEAN ; + +PACKAGE CC3019C1_NESTED_GENERICS IS + + TYPE NESTED_GENERICS_TYPE IS LIMITED PRIVATE ; + + PROCEDURE COPY (SOURCE : IN OUT NESTED_GENERICS_TYPE ; + DESTINATION : IN OUT NESTED_GENERICS_TYPE) ; + + PROCEDURE SET_ELEMENT + (FOR_THIS_NGT_OBJECT : IN OUT NESTED_GENERICS_TYPE ; + TO_THIS_ELEMENT : IN OUT ELEMENT) ; + + PROCEDURE SET_NUMBER + (FOR_THIS_NGT_OBJECT : IN OUT NESTED_GENERICS_TYPE ; + TO_THIS_NUMBER : IN NATURAL) ; + + FUNCTION "=" (LEFT : IN NESTED_GENERICS_TYPE ; + RIGHT : IN NESTED_GENERICS_TYPE) RETURN BOOLEAN ; + + FUNCTION ELEMENT_OF (THIS_NGT_OBJECT : IN NESTED_GENERICS_TYPE) + RETURN ELEMENT ; + + FUNCTION NUMBER_OF (THIS_NGT_OBJECT : IN NESTED_GENERICS_TYPE) + RETURN NATURAL ; + + GENERIC + + TYPE ELEMENT IS LIMITED PRIVATE ; + + WITH PROCEDURE ASSIGN (SOURCE : IN OUT ELEMENT ; + DESTINATION : IN OUT ELEMENT) ; + + PACKAGE GENERIC_TASK IS + + TASK TYPE PROTECTED_AREA IS + + ENTRY STORE (ITEM : IN OUT ELEMENT) ; + ENTRY GET (ITEM : IN OUT ELEMENT) ; + + END PROTECTED_AREA ; + + END GENERIC_TASK ; + + GENERIC + + TYPE ELEMENT IS LIMITED PRIVATE ; + + WITH PROCEDURE ASSIGN (SOURCE : IN OUT ELEMENT ; + DESTINATION : IN OUT ELEMENT) ; + + WITH FUNCTION "=" (LEFT : IN ELEMENT ; + RIGHT : IN ELEMENT) RETURN BOOLEAN ; + + PACKAGE STACK_CLASS IS + + TYPE STACK IS LIMITED PRIVATE ; + + OVERFLOW : EXCEPTION ; + UNDERFLOW : EXCEPTION ; + + PROCEDURE PUSH (THIS_ELEMENT : IN OUT ELEMENT ; + ON_TO_THIS_STACK : IN OUT STACK) ; + + PROCEDURE POP (THIS_ELEMENT : IN OUT ELEMENT ; + OFF_THIS_STACK : IN OUT STACK) ; + + PROCEDURE COPY (THIS_STACK : IN OUT STACK ; + TO_THIS_STACK : IN OUT STACK) ; + + PROCEDURE CLEAR (THIS_STACK : IN OUT STACK) ; + + GENERIC + + WITH PROCEDURE PROCESS (THIS_ELEMENT : IN ELEMENT ; + CONTINUE : OUT BOOLEAN) ; + + PROCEDURE ITERATE (OVER_THIS_STACK : IN STACK) ; + + FUNCTION NUMBER_OF_ELEMENTS (ON_THIS_STACK : IN STACK) + RETURN NATURAL ; + + FUNCTION "=" (LEFT : IN STACK ; + RIGHT : IN STACK) RETURN BOOLEAN ; + + PRIVATE + + PACKAGE NEW_LIST_CLASS IS NEW + CC3019C0_LIST_CLASS (ELEMENT => ELEMENT, + ASSIGN => ASSIGN, + "=" => "=") ; + + TYPE STACK IS NEW NEW_LIST_CLASS.LIST ; + + END STACK_CLASS ; + +PRIVATE + + TYPE NESTED_GENERICS_TYPE IS RECORD + FIRST : ELEMENT ; + SECOND : NATURAL ; + END RECORD ; + +END CC3019C1_NESTED_GENERICS ; + +PACKAGE BODY CC3019C1_NESTED_GENERICS IS + + PROCEDURE COPY (SOURCE : IN OUT NESTED_GENERICS_TYPE ; + DESTINATION : IN OUT NESTED_GENERICS_TYPE) IS + + BEGIN -- COPY + + ASSIGN (SOURCE => SOURCE.FIRST, + DESTINATION => DESTINATION.FIRST) ; + + DESTINATION.SECOND := SOURCE.SECOND ; + + END COPY ; + + PROCEDURE SET_ELEMENT + (FOR_THIS_NGT_OBJECT : IN OUT NESTED_GENERICS_TYPE ; + TO_THIS_ELEMENT : IN OUT ELEMENT) IS + + BEGIN -- SET_ELEMENT + + ASSIGN (SOURCE => TO_THIS_ELEMENT, + DESTINATION => FOR_THIS_NGT_OBJECT.FIRST) ; + + END SET_ELEMENT ; + + PROCEDURE SET_NUMBER + (FOR_THIS_NGT_OBJECT : IN OUT NESTED_GENERICS_TYPE ; + TO_THIS_NUMBER : IN NATURAL) IS + + BEGIN -- SET_NUMBER + + FOR_THIS_NGT_OBJECT.SECOND := TO_THIS_NUMBER ; + + END SET_NUMBER ; + + FUNCTION "=" (LEFT : IN NESTED_GENERICS_TYPE ; + RIGHT : IN NESTED_GENERICS_TYPE) RETURN BOOLEAN IS + + BEGIN -- "=" + + IF (LEFT.FIRST = RIGHT.FIRST) AND + (LEFT.SECOND = RIGHT.SECOND) THEN + RETURN TRUE ; + ELSE + RETURN FALSE ; + END IF ; + + END "=" ; + + FUNCTION ELEMENT_OF (THIS_NGT_OBJECT : IN NESTED_GENERICS_TYPE) + RETURN ELEMENT IS + + BEGIN -- ELEMENT_OF + + RETURN THIS_NGT_OBJECT.FIRST ; + + END ELEMENT_OF ; + + FUNCTION NUMBER_OF (THIS_NGT_OBJECT : IN NESTED_GENERICS_TYPE) + RETURN NATURAL IS + + BEGIN -- NUMBER_OF + + RETURN THIS_NGT_OBJECT.SECOND ; + + END NUMBER_OF ; + + PACKAGE BODY GENERIC_TASK IS + + TASK BODY PROTECTED_AREA IS + + LOCAL_STORE : ELEMENT ; + + BEGIN -- PROTECTED_AREA + + LOOP + SELECT + ACCEPT STORE (ITEM : IN OUT ELEMENT) DO + ASSIGN (SOURCE => ITEM, + DESTINATION => LOCAL_STORE) ; + END STORE ; + OR + ACCEPT GET (ITEM : IN OUT ELEMENT) DO + ASSIGN (SOURCE => LOCAL_STORE, + DESTINATION => ITEM) ; + END GET ; + OR + TERMINATE ; + END SELECT ; + END LOOP ; + + END PROTECTED_AREA ; + + END GENERIC_TASK ; + + PACKAGE BODY STACK_CLASS IS + + PROCEDURE PUSH (THIS_ELEMENT : IN OUT ELEMENT ; + ON_TO_THIS_STACK : IN OUT STACK) IS + + BEGIN -- PUSH + + NEW_LIST_CLASS.ADD ( + THIS_ELEMENT => THIS_ELEMENT, + TO_THIS_LIST => + NEW_LIST_CLASS.LIST (ON_TO_THIS_STACK)) ; + + EXCEPTION + + WHEN NEW_LIST_CLASS.OVERFLOW => RAISE OVERFLOW ; + + END PUSH ; + + PROCEDURE POP (THIS_ELEMENT : IN OUT ELEMENT ; + OFF_THIS_STACK : IN OUT STACK) IS + + BEGIN -- POP + + NEW_LIST_CLASS.DELETE ( + THIS_ELEMENT => THIS_ELEMENT, + FROM_THIS_LIST => + NEW_LIST_CLASS.LIST (OFF_THIS_STACK)) ; + + EXCEPTION + + WHEN NEW_LIST_CLASS.UNDERFLOW => RAISE UNDERFLOW ; + + END POP ; + + PROCEDURE COPY (THIS_STACK : IN OUT STACK ; + TO_THIS_STACK : IN OUT STACK) IS + + BEGIN -- COPY + + NEW_LIST_CLASS.COPY ( + THIS_LIST => NEW_LIST_CLASS.LIST (THIS_STACK), + TO_THIS_LIST => + NEW_LIST_CLASS.LIST (TO_THIS_STACK)) ; + + END COPY ; + + PROCEDURE CLEAR (THIS_STACK : IN OUT STACK) IS + + BEGIN -- CLEAR + + NEW_LIST_CLASS.CLEAR (NEW_LIST_CLASS.LIST (THIS_STACK)) ; + + END CLEAR ; + + PROCEDURE ITERATE (OVER_THIS_STACK : IN STACK) IS + + PROCEDURE STACK_ITERATE IS NEW NEW_LIST_CLASS.ITERATE + (PROCESS => PROCESS) ; + + BEGIN -- ITERATE + + STACK_ITERATE (NEW_LIST_CLASS.LIST (OVER_THIS_STACK)) ; + + END ITERATE ; + + FUNCTION NUMBER_OF_ELEMENTS (ON_THIS_STACK : IN STACK) + RETURN NATURAL IS + + BEGIN -- NUMBER_OF_ELEMENTS + + RETURN NEW_LIST_CLASS.NUMBER_OF_ELEMENTS + (IN_THIS_LIST => + NEW_LIST_CLASS.LIST (ON_THIS_STACK)) ; + + END NUMBER_OF_ELEMENTS ; + + FUNCTION "=" (LEFT : IN STACK ; + RIGHT : IN STACK) RETURN BOOLEAN IS + + BEGIN -- "=" + + RETURN NEW_LIST_CLASS."=" ( + LEFT => NEW_LIST_CLASS.LIST (LEFT), + RIGHT => NEW_LIST_CLASS.LIST (RIGHT)) ; + + END "=" ; + + END STACK_CLASS ; + +END CC3019C1_NESTED_GENERICS ; diff --git a/gcc/testsuite/ada/acats/tests/cc/cc3019c2.ada b/gcc/testsuite/ada/acats/tests/cc/cc3019c2.ada new file mode 100644 index 000000000..8fab9e623 --- /dev/null +++ b/gcc/testsuite/ada/acats/tests/cc/cc3019c2.ada @@ -0,0 +1,457 @@ +-- CC3019C2M.ADA + +-- Grant of Unlimited Rights +-- +-- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687, +-- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained +-- unlimited rights in the software and documentation contained herein. +-- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making +-- this public release, the Government intends to confer upon all +-- recipients unlimited rights equal to those held by the Government. +-- These rights include rights to use, duplicate, release or disclose the +-- released technical data and computer software in whole or in part, in +-- any manner and for any purpose whatsoever, and to have or permit others +-- to do so. +-- +-- DISCLAIMER +-- +-- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR +-- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED +-- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF 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 INSTANTIATIONS OF UNITS WITHIN GENERIC UNITS, E.G. +-- TO SUPPORT ITERATORS. + +-- THIS TEST SPECIFICALLY CHECKS THAT A +-- NESTING LEVEL OF 3 IS SUPPORTED FOR GENERICS: +-- INSTANTIATE CC3019C1_NESTED_GENERICS IN THE MAIN +-- PROCEDURE, THE INSTANTIATION OF CC3019C0_LIST_CLASS +-- IN GENERIC PACKAGE CC3019C1_NESTED_GENERICS, AND +-- THE INSTANTIATION OF NEW_LIST_CLASS.ITERATE IN +-- PROCEDURE ITERATE IN PACKAGE BODY STACK_CLASS. +-- +-- *** THIS IS THE MAIN PROGRAM. IT MUST BE COMPILED AFTER THE +-- *** SOURCE CODE IN FILES CC3019C0.ADA AND CC3019C1.ADA HAVE +-- *** BEEN COMPILED. +-- +-- HISTORY: +-- EDWARD V. BERARD, 31 AUGUST 1990 + +WITH REPORT ; +WITH CC3019C1_NESTED_GENERICS ; + +PROCEDURE CC3019C2M IS + + TYPE MONTH_TYPE IS (JAN, FEB, MAR, APR, MAY, JUN, JUL, AUG, + SEP, OCT, NOV, DEC) ; + TYPE DAY_TYPE IS RANGE 1 .. 31 ; + TYPE YEAR_TYPE IS RANGE 1904 .. 2050 ; + TYPE DATE IS RECORD + MONTH : MONTH_TYPE ; + DAY : DAY_TYPE ; + YEAR : YEAR_TYPE ; + END RECORD ; + + STORE_DATE : DATE ; + + TODAY : DATE := (MONTH => AUG, + DAY => 31, + YEAR => 1990) ; + + FIRST_DATE : DATE := (MONTH => JUN, + DAY => 4, + YEAR => 1967) ; + + BIRTH_DATE : DATE := (MONTH => OCT, + DAY => 3, + YEAR => 1949) ; + + WALL_DATE : DATE := (MONTH => NOV, + DAY => 9, + YEAR => 1989) ; + + TYPE SEX IS (MALE, FEMALE) ; + + TYPE PERSON IS RECORD + BIRTH_DATE : DATE ; + GENDER : SEX ; + NAME : STRING (1 .. 10) ; + END RECORD ; + + FIRST_PERSON : PERSON ; + SECOND_PERSON : PERSON ; + + MYSELF : PERSON := (BIRTH_DATE => BIRTH_DATE, + GENDER => MALE, + NAME => "ED ") ; + + FRIEND : PERSON := (BIRTH_DATE => DATE'(DEC, 27, 1949), + GENDER => MALE, + NAME => "DENNIS ") ; + + FATHER : PERSON := (BIRTH_DATE => DATE'(JUL, 5, 1925), + GENDER => MALE, + NAME => "EDWARD ") ; + + DAUGHTER : PERSON := (BIRTH_DATE => DATE'(DEC, 10, 1980), + GENDER => FEMALE, + NAME => "CHRISSY ") ; + + PROCEDURE ASSIGN (THE_VALUE_OF_THIS_DATE : IN OUT DATE ; + TO_THIS_DATE : IN OUT DATE) ; + + FUNCTION IS_EQUAL (LEFT : IN DATE ; + RIGHT : IN DATE) RETURN BOOLEAN ; + + PROCEDURE ASSIGN (THE_VALUE_OF_THIS_PERSON : IN OUT PERSON ; + TO_THIS_PERSON : IN OUT PERSON) ; + + FUNCTION IS_EQUAL (LEFT : IN PERSON ; + RIGHT : IN PERSON) RETURN BOOLEAN ; + +-- INSTANTIATE OUTER GENERIC PACKAGE + + PACKAGE NEW_NESTED_GENERICS IS NEW + CC3019C1_NESTED_GENERICS (ELEMENT => DATE, + ASSIGN => ASSIGN, + "=" => IS_EQUAL) ; + + FIRST_NNG : NEW_NESTED_GENERICS.NESTED_GENERICS_TYPE ; + SECOND_NNG : NEW_NESTED_GENERICS.NESTED_GENERICS_TYPE ; + + FUNCTION "=" (LEFT : IN NEW_NESTED_GENERICS.NESTED_GENERICS_TYPE ; + RIGHT : IN NEW_NESTED_GENERICS.NESTED_GENERICS_TYPE) + RETURN BOOLEAN RENAMES NEW_NESTED_GENERICS."=" ; + +-- INSTANTIATE NESTED TASK PACKAGE + + PACKAGE NEW_GENERIC_TASK IS NEW + NEW_NESTED_GENERICS.GENERIC_TASK (ELEMENT => PERSON, + ASSIGN => ASSIGN) ; + + FIRST_GENERIC_TASK : NEW_GENERIC_TASK.PROTECTED_AREA ; + SECOND_GENERIC_TASK : NEW_GENERIC_TASK.PROTECTED_AREA ; + +-- INSTANTIATE NESTED STACK PACKAGE + + PACKAGE PERSON_STACK IS NEW + NEW_NESTED_GENERICS.STACK_CLASS (ELEMENT => PERSON, + ASSIGN => ASSIGN, + "=" => IS_EQUAL) ; + + FIRST_PERSON_STACK : PERSON_STACK.STACK ; + SECOND_PERSON_STACK : PERSON_STACK.STACK ; + THIRD_PERSON_STACK : PERSON_STACK.STACK ; + + FUNCTION "=" (LEFT : IN PERSON_STACK.STACK ; + RIGHT : IN PERSON_STACK.STACK) RETURN BOOLEAN + RENAMES PERSON_STACK."=" ; + + PROCEDURE ASSIGN (THE_VALUE_OF_THIS_DATE : IN OUT DATE ; + TO_THIS_DATE : IN OUT DATE) IS + + BEGIN -- ASSIGN + + TO_THIS_DATE := THE_VALUE_OF_THIS_DATE ; + + END ASSIGN ; + + FUNCTION IS_EQUAL (LEFT : IN DATE ; + RIGHT : IN DATE) RETURN BOOLEAN IS + + BEGIN -- IS_EQUAL + + IF (LEFT.MONTH = RIGHT.MONTH) AND (LEFT.DAY = RIGHT.DAY) + AND (LEFT.YEAR = RIGHT.YEAR) THEN + RETURN TRUE ; + ELSE + RETURN FALSE ; + END IF ; + + END IS_EQUAL ; + + PROCEDURE ASSIGN (THE_VALUE_OF_THIS_PERSON : IN OUT PERSON ; + TO_THIS_PERSON : IN OUT PERSON) IS + + BEGIN -- ASSIGN + + TO_THIS_PERSON := THE_VALUE_OF_THIS_PERSON ; + + END ASSIGN ; + + FUNCTION IS_EQUAL (LEFT : IN PERSON ; + RIGHT : IN PERSON) RETURN BOOLEAN IS + + BEGIN -- IS_EQUAL + + IF (LEFT.BIRTH_DATE = RIGHT.BIRTH_DATE) AND + (LEFT.GENDER = RIGHT.GENDER) AND + (LEFT.NAME = RIGHT.NAME) THEN + RETURN TRUE ; + ELSE + RETURN FALSE ; + END IF ; + + END IS_EQUAL ; + +BEGIN -- CC3019C2M + + REPORT.TEST ("CC3019C2M", + "CHECK INSTANTIATIONS OF UNITS WITHIN GENERIC " & + "UNITS, E.G., TO SUPPORT ITERATORS. THIS TEST " & + "SPECIFICALLY CHECKS THAT A NESTING LEVEL OF 3 " & + "IS SUPPORTED FOR GENERICS.") ; + +-- CHECK THE OUTERMOST GENERIC (NEW_NESTED_GENERICS) + + NEW_NESTED_GENERICS.SET_ELEMENT ( + FOR_THIS_NGT_OBJECT => FIRST_NNG, + TO_THIS_ELEMENT => TODAY) ; + NEW_NESTED_GENERICS.SET_NUMBER ( + FOR_THIS_NGT_OBJECT => FIRST_NNG, + TO_THIS_NUMBER => 1) ; + + NEW_NESTED_GENERICS.SET_ELEMENT ( + FOR_THIS_NGT_OBJECT => SECOND_NNG, + TO_THIS_ELEMENT => FIRST_DATE) ; + NEW_NESTED_GENERICS.SET_NUMBER ( + FOR_THIS_NGT_OBJECT => SECOND_NNG, + TO_THIS_NUMBER => 2) ; + + IF FIRST_NNG = SECOND_NNG THEN + REPORT.FAILED ("PROBLEMS WITH TESTING EQUALITY FOR " & + "OUTERMOST GENERIC") ; + END IF ; + + IF (NEW_NESTED_GENERICS.ELEMENT_OF (THIS_NGT_OBJECT => FIRST_NNG) + /= TODAY) OR + (NEW_NESTED_GENERICS.ELEMENT_OF ( + THIS_NGT_OBJECT => SECOND_NNG) + /= FIRST_DATE) THEN + REPORT.FAILED ("PROBLEMS WITH EXTRACTING ELEMENTS IN " & + "OUTERMOST GENERIC") ; + END IF ; + + IF (NEW_NESTED_GENERICS.NUMBER_OF (THIS_NGT_OBJECT => FIRST_NNG) + /= 1) OR + (NEW_NESTED_GENERICS.NUMBER_OF (THIS_NGT_OBJECT => SECOND_NNG) + /= 2) THEN + REPORT.FAILED ("PROBLEMS WITH EXTRACTING NUMBERS IN " & + "OUTERMOST GENERIC") ; + END IF ; + + NEW_NESTED_GENERICS.COPY (SOURCE => FIRST_NNG, + DESTINATION => SECOND_NNG) ; + + IF FIRST_NNG /= SECOND_NNG THEN + REPORT.FAILED ("PROBLEMS WITH COPYING OR TESTING EQUALITY " & + "IN OUTERMOST GENERIC") ; + END IF ; + +-- CHECK THE FIRST NESTED GENERIC (GENERIC_TASK) + + FIRST_GENERIC_TASK.STORE (ITEM => MYSELF) ; + SECOND_GENERIC_TASK.STORE (ITEM => FRIEND) ; + + FIRST_GENERIC_TASK.GET (ITEM => FIRST_PERSON) ; + SECOND_GENERIC_TASK.GET (ITEM => SECOND_PERSON) ; + + IF (FIRST_PERSON /= MYSELF) OR (SECOND_PERSON /= FRIEND) THEN + REPORT.FAILED ("PROBLEMS WITH NESTED TASK GENERIC") ; + END IF ; + +-- CHECK THE SECOND NESTED GENERIC (STACK_CLASS) + + PERSON_STACK.CLEAR (THIS_STACK => FIRST_PERSON_STACK) ; + IF PERSON_STACK.NUMBER_OF_ELEMENTS + (ON_THIS_STACK => FIRST_PERSON_STACK) /= 0 THEN + REPORT.FAILED ( + "IMPROPER VALUE RETURNED FROM NUMBER_OF_ELEMENTS - 1") ; + END IF ; + + PERSON_STACK.PUSH (THIS_ELEMENT => MYSELF, + ON_TO_THIS_STACK => FIRST_PERSON_STACK) ; + IF PERSON_STACK.NUMBER_OF_ELEMENTS + (ON_THIS_STACK => FIRST_PERSON_STACK) /= 1 THEN + REPORT.FAILED ( + "IMPROPER VALUE RETURNED FROM NUMBER_OF_ELEMENTS - 2") ; + END IF ; + + PERSON_STACK.PUSH (THIS_ELEMENT => FRIEND, + ON_TO_THIS_STACK => FIRST_PERSON_STACK) ; + IF PERSON_STACK.NUMBER_OF_ELEMENTS + (ON_THIS_STACK => FIRST_PERSON_STACK) /= 2 THEN + REPORT.FAILED ( + "IMPROPER VALUE RETURNED FROM NUMBER_OF_ELEMENTS - 3") ; + END IF ; + + PERSON_STACK.PUSH (THIS_ELEMENT => FATHER, + ON_TO_THIS_STACK => FIRST_PERSON_STACK) ; + IF PERSON_STACK.NUMBER_OF_ELEMENTS + (ON_THIS_STACK => FIRST_PERSON_STACK) /= 3 THEN + REPORT.FAILED ( + "IMPROPER VALUE RETURNED FROM NUMBER_OF_ELEMENTS - 4") ; + END IF ; + + PERSON_STACK.POP (THIS_ELEMENT => FIRST_PERSON, + OFF_THIS_STACK => FIRST_PERSON_STACK) ; + IF PERSON_STACK.NUMBER_OF_ELEMENTS + (ON_THIS_STACK => FIRST_PERSON_STACK) /= 2 THEN + REPORT.FAILED ( + "IMPROPER VALUE RETURNED FROM NUMBER_OF_ELEMENTS - 5") ; + END IF ; + + IF FIRST_PERSON /= FATHER THEN + REPORT.FAILED ( + "IMPROPER VALUE REMOVED FROM STACK - 1") ; + END IF ; + + PERSON_STACK.CLEAR (THIS_STACK => SECOND_PERSON_STACK) ; + IF PERSON_STACK.NUMBER_OF_ELEMENTS + (ON_THIS_STACK => SECOND_PERSON_STACK) /= 0 THEN + REPORT.FAILED ( + "IMPROPER VALUE RETURNED FROM NUMBER_OF_ELEMENTS - 6") ; + END IF ; + + PERSON_STACK.COPY (THIS_STACK => FIRST_PERSON_STACK, + TO_THIS_STACK => SECOND_PERSON_STACK) ; + + IF FIRST_PERSON_STACK /= SECOND_PERSON_STACK THEN + REPORT.FAILED ( + "PROBLEMS WITH COPY OR TEST FOR EQUALITY (STACK)") ; + END IF ; + + PERSON_STACK.POP (THIS_ELEMENT => FIRST_PERSON, + OFF_THIS_STACK => SECOND_PERSON_STACK) ; + PERSON_STACK.PUSH (THIS_ELEMENT => DAUGHTER, + ON_TO_THIS_STACK => SECOND_PERSON_STACK) ; + IF FIRST_PERSON_STACK = SECOND_PERSON_STACK THEN + REPORT.FAILED ( + "PROBLEMS WITH POP OR TEST FOR EQUALITY (STACK)") ; + END IF ; + + UNDERFLOW_EXCEPTION_TEST: + + BEGIN -- UNDERFLOW_EXCEPTION_TEST + + PERSON_STACK.CLEAR (THIS_STACK => THIRD_PERSON_STACK) ; + PERSON_STACK.POP (THIS_ELEMENT => FIRST_PERSON, + OFF_THIS_STACK => THIRD_PERSON_STACK) ; + REPORT.FAILED ("UNDERFLOW EXCEPTION NOT RAISED") ; + + EXCEPTION + + WHEN PERSON_STACK.UNDERFLOW => NULL ; -- CORRECT EXCEPTION + -- RAISED + WHEN OTHERS => + REPORT.FAILED ("INCORRECT EXCEPTION RAISED IN " & + "UNDERFLOW EXCEPTION TEST") ; + + END UNDERFLOW_EXCEPTION_TEST ; + + OVERFLOW_EXCEPTION_TEST: + + BEGIN -- OVERFLOW_EXCEPTION_TEST + + PERSON_STACK.CLEAR (THIS_STACK => THIRD_PERSON_STACK) ; + FOR INDEX IN 1 .. 10 LOOP + PERSON_STACK.PUSH ( + THIS_ELEMENT => MYSELF, + ON_TO_THIS_STACK => THIRD_PERSON_STACK) ; + END LOOP ; + + PERSON_STACK.PUSH (THIS_ELEMENT => MYSELF, + ON_TO_THIS_STACK => THIRD_PERSON_STACK) ; + REPORT.FAILED ("OVERFLOW EXCEPTION NOT RAISED") ; + + EXCEPTION + + WHEN PERSON_STACK.OVERFLOW => NULL ; -- CORRECT EXCEPTION + -- RAISED + WHEN OTHERS => + REPORT.FAILED ("INCORRECT EXCEPTION RAISED IN " & + "OVERFLOW EXCEPTION TEST") ; + + END OVERFLOW_EXCEPTION_TEST ; + + LOCAL_BLOCK: + + DECLARE + + TYPE PERSON_TABLE IS ARRAY (POSITIVE RANGE 1 .. 10) OF PERSON; + + FIRST_PERSON_TABLE : PERSON_TABLE ; + + TABLE_INDEX : POSITIVE := 1 ; + + PROCEDURE GATHER_PEOPLE (THIS_PERSON : IN PERSON ; + CONTINUE : OUT BOOLEAN) ; + + PROCEDURE SHOW_PEOPLE (THIS_PERSON : IN PERSON ; + CONTINUE : OUT BOOLEAN) ; + + PROCEDURE GATHER_PERSON_ITERATE IS NEW + PERSON_STACK.ITERATE (PROCESS => GATHER_PEOPLE) ; + + PROCEDURE SHOW_PERSON_ITERATE IS NEW + PERSON_STACK.ITERATE (PROCESS => SHOW_PEOPLE) ; + + PROCEDURE GATHER_PEOPLE (THIS_PERSON : IN PERSON ; + CONTINUE : OUT BOOLEAN) IS + BEGIN -- GATHER_PEOPLE + + FIRST_PERSON_TABLE (TABLE_INDEX) := THIS_PERSON ; + TABLE_INDEX := TABLE_INDEX + 1 ; + + CONTINUE := TRUE ; + + END GATHER_PEOPLE ; + + PROCEDURE SHOW_PEOPLE (THIS_PERSON : IN PERSON ; + CONTINUE : OUT BOOLEAN) IS + + BEGIN -- SHOW_PEOPLE + + REPORT.COMMENT ("THE BIRTH MONTH IS " & + MONTH_TYPE'IMAGE (THIS_PERSON.BIRTH_DATE.MONTH)) ; + REPORT.COMMENT ("THE BIRTH DAY IS " & + DAY_TYPE'IMAGE (THIS_PERSON.BIRTH_DATE.DAY)) ; + REPORT.COMMENT ("THE BIRTH YEAR IS " & + YEAR_TYPE'IMAGE (THIS_PERSON.BIRTH_DATE.YEAR)) ; + REPORT.COMMENT ("THE GENDER IS " & + SEX'IMAGE (THIS_PERSON.GENDER)) ; + REPORT.COMMENT ("THE NAME IS " & THIS_PERSON.NAME) ; + + CONTINUE := TRUE ; + + END SHOW_PEOPLE ; + + BEGIN -- LOCAL_BLOCK + + REPORT.COMMENT ("CONTENTS OF THE FIRST STACK") ; + SHOW_PERSON_ITERATE (OVER_THIS_STACK => FIRST_PERSON_STACK) ; + + REPORT.COMMENT ("CONTENTS OF THE SECOND STACK") ; + SHOW_PERSON_ITERATE (OVER_THIS_STACK => SECOND_PERSON_STACK) ; + + GATHER_PERSON_ITERATE (OVER_THIS_STACK => FIRST_PERSON_STACK); + IF (FIRST_PERSON_TABLE (1) /= MYSELF) OR + (FIRST_PERSON_TABLE (2) /= FRIEND) THEN + REPORT.FAILED ("PROBLEMS WITH ITERATION - 1") ; + END IF ; + + TABLE_INDEX := 1 ; + GATHER_PERSON_ITERATE(OVER_THIS_STACK => SECOND_PERSON_STACK); + IF (FIRST_PERSON_TABLE (1) /= MYSELF) OR + (FIRST_PERSON_TABLE (2) /= DAUGHTER) THEN + REPORT.FAILED ("PROBLEMS WITH ITERATION - 2") ; + END IF ; + + END LOCAL_BLOCK ; + + REPORT.RESULT ; + +END CC3019C2M ; diff --git a/gcc/testsuite/ada/acats/tests/cc/cc3106b.ada b/gcc/testsuite/ada/acats/tests/cc/cc3106b.ada new file mode 100644 index 000000000..cd238c17a --- /dev/null +++ b/gcc/testsuite/ada/acats/tests/cc/cc3106b.ada @@ -0,0 +1,207 @@ +-- CC3106B.ADA + +-- Grant of Unlimited Rights +-- +-- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687, +-- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained +-- unlimited rights in the software and documentation contained herein. +-- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making +-- this public release, the Government intends to confer upon all +-- recipients unlimited rights equal to those held by the Government. +-- These rights include rights to use, duplicate, release or disclose the +-- released technical data and computer software in whole or in part, in +-- any manner and for any purpose whatsoever, and to have or permit others +-- to do so. +-- +-- DISCLAIMER +-- +-- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR +-- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED +-- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF 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 FORMAL PARAMETER DENOTES THE ACTUAL +-- IN AN INSTANTIATION. + +-- HISTORY: +-- LDC 06/20/88 CREATED ORIGINAL TEST +-- EDWARD V. BERARD, 10 AUGUST 1990 ADDED CHECKS FOR MULTI- +-- DIMENSIONAL ARRAYS + +WITH REPORT ; + +PROCEDURE CC3106B IS + +BEGIN -- CC3106B + + REPORT.TEST("CC3106B","CHECK THAT THE FORMAL PARAMETER DENOTES " & + "THE ACTUAL IN AN INSTANTIATION"); + + LOCAL_BLOCK: + + DECLARE + + SUBTYPE SM_INT IS INTEGER RANGE 0..15 ; + TYPE PCK_BOL IS ARRAY (5..18) OF BOOLEAN ; + PRAGMA PACK(PCK_BOL) ; + + SHORT_START : CONSTANT := -100 ; + SHORT_END : CONSTANT := 100 ; + TYPE SHORT_RANGE IS RANGE SHORT_START .. SHORT_END ; + + SUBTYPE REALLY_SHORT IS SHORT_RANGE RANGE -9 .. 0 ; + + TYPE MONTH_TYPE IS (JAN, FEB, MAR, APR, MAY, JUN, JUL, AUG, + SEP, OCT, NOV, DEC) ; + + SUBTYPE FIRST_HALF IS MONTH_TYPE RANGE JAN .. JUN ; + + TYPE DAY_TYPE IS RANGE 1 .. 31 ; + TYPE YEAR_TYPE IS RANGE 1904 .. 2050 ; + TYPE DATE IS RECORD + MONTH : MONTH_TYPE ; + DAY : DAY_TYPE ; + YEAR : YEAR_TYPE ; + END RECORD ; + + TODAY : DATE := (MONTH => AUG, + DAY => 8, + YEAR => 1990) ; + + FIRST_DATE : DATE := (DAY => 6, + MONTH => JUN, + YEAR => 1967) ; + + WALL_DATE : DATE := (MONTH => NOV, + DAY => 9, + YEAR => 1989) ; + + SUBTYPE FIRST_FIVE IS CHARACTER RANGE 'A' .. 'E' ; + + TYPE THREE_DIMENSIONAL IS ARRAY (REALLY_SHORT, + FIRST_HALF, + FIRST_FIVE) OF DATE ; + + TD_ARRAY : THREE_DIMENSIONAL := (THREE_DIMENSIONAL'RANGE => + (THREE_DIMENSIONAL'RANGE (2) => + (THREE_DIMENSIONAL'RANGE (3) => + TODAY))) ; + + TASK TYPE TSK IS + ENTRY ENT_1; + ENTRY ENT_2; + ENTRY ENT_3; + END TSK; + + GENERIC + + TYPE GEN_TYPE IS (<>); + GEN_BOLARR : IN OUT PCK_BOL; + GEN_TYP : IN OUT GEN_TYPE; + GEN_TSK : IN OUT TSK; + TEST_VALUE : IN DATE ; + TEST_CUBE : IN OUT THREE_DIMENSIONAL ; + + PACKAGE P IS + PROCEDURE GEN_PROC1 ; + PROCEDURE GEN_PROC2 ; + PROCEDURE GEN_PROC3 ; + PROCEDURE ARRAY_TEST ; + END P; + + ACT_BOLARR : PCK_BOL := (OTHERS => FALSE); + SI : SM_INT := 0 ; + T : TSK; + + PACKAGE BODY P IS + + PROCEDURE GEN_PROC1 IS + BEGIN -- GEN_PROC1 + GEN_BOLARR(14) := REPORT.IDENT_BOOL(TRUE); + GEN_TYP := GEN_TYPE'VAL(4); + IF ACT_BOLARR(14) /= TRUE OR SI /= REPORT.IDENT_INT(4) + THEN + REPORT.FAILED("VALUES ARE DIFFERENT THAN " & + "INSTANTIATED VALUES"); + END IF; + END GEN_PROC1; + + PROCEDURE GEN_PROC2 IS + BEGIN -- GEN_PROC2 + IF GEN_BOLARR(9) /= REPORT.IDENT_BOOL(TRUE) OR + GEN_TYPE'POS(GEN_TYP) /= REPORT.IDENT_INT(2) THEN + REPORT.FAILED("VALUES ARE DIFFERENT THAN " & + "VALUES ASSIGNED IN THE MAIN " & + "PROCEDURE"); + END IF; + GEN_BOLARR(18) := TRUE; + GEN_TYP := GEN_TYPE'VAL(9); + END GEN_PROC2; + + PROCEDURE GEN_PROC3 IS + BEGIN -- GEN_PROC3 + GEN_TSK.ENT_2; + END GEN_PROC3 ; + + PROCEDURE ARRAY_TEST IS + BEGIN -- ARRAY_TEST + + TEST_CUBE (0, JUN, 'C') := TEST_VALUE ; + + IF (TD_ARRAY (0, JUN, 'C') /= TEST_VALUE) OR + (TEST_CUBE (-5, MAR, 'A') /= WALL_DATE) THEN + REPORT.FAILED ("MULTI-DIMENSIONAL ARRAY VALUES ARE " & + "DIFFERENT THAN THE VALUES ASSIGNED " & + "IN THE MAIN AND ARRAY_TEST PROCEDURES.") ; + END IF ; + + END ARRAY_TEST ; + + END P ; + + TASK BODY TSK IS + BEGIN -- TSK + ACCEPT ENT_1 DO + REPORT.COMMENT("TASK ENTRY 1 WAS CALLED"); + END; + ACCEPT ENT_2 DO + REPORT.COMMENT("TASK ENTRY 2 WAS CALLED"); + END; + ACCEPT ENT_3 DO + REPORT.COMMENT("TASK ENTRY 3 WAS CALLED"); + END; + END TSK; + + PACKAGE INSTA1 IS NEW P (GEN_TYPE => SM_INT, + GEN_BOLARR => ACT_BOLARR, + GEN_TYP => SI, + GEN_TSK => T, + TEST_VALUE => FIRST_DATE, + TEST_CUBE => TD_ARRAY) ; + + BEGIN -- LOCAL_BLOCK + + INSTA1.GEN_PROC1; + ACT_BOLARR(9) := TRUE; + SI := 2; + INSTA1.GEN_PROC2; + IF ACT_BOLARR(18) /= REPORT.IDENT_BOOL(TRUE) OR + SI /= REPORT.IDENT_INT(9) THEN + REPORT.FAILED("VALUES ARE DIFFERENT THAN VALUES " & + "ASSIGNED IN THE GENERIC PROCEDURE"); + END IF; + + T.ENT_1; + INSTA1.GEN_PROC3; + T.ENT_3; + + TD_ARRAY (-5, MAR, 'A') := WALL_DATE ; + INSTA1.ARRAY_TEST ; + + END LOCAL_BLOCK; + + REPORT.RESULT; + +END CC3106B ; diff --git a/gcc/testsuite/ada/acats/tests/cc/cc3120a.ada b/gcc/testsuite/ada/acats/tests/cc/cc3120a.ada new file mode 100644 index 000000000..dc709c322 --- /dev/null +++ b/gcc/testsuite/ada/acats/tests/cc/cc3120a.ada @@ -0,0 +1,180 @@ +-- CC3120A.ADA + +-- Grant of Unlimited Rights +-- +-- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687, +-- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained +-- unlimited rights in the software and documentation contained herein. +-- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making +-- this public release, the Government intends to confer upon all +-- recipients unlimited rights equal to those held by the Government. +-- These rights include rights to use, duplicate, release or disclose the +-- released technical data and computer software in whole or in part, in +-- any manner and for any purpose whatsoever, and to have or permit others +-- to do so. +-- +-- DISCLAIMER +-- +-- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR +-- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED +-- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF 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 GENERIC IN PARAMETERS ARE ALWAYS COPIED, AND THAT +-- GENERIC IN OUT PARAMETERS ARE ALWAYS RENAMED. + +-- DAT 8/10/81 +-- SPS 10/21/82 + +WITH REPORT; USE REPORT; + +PROCEDURE CC3120A IS +BEGIN + TEST ("CC3120A", "GENERIC IN PARMS ARE COPIED, GENERIC IN OUT" + & " PARMS ARE RENAMED"); + + DECLARE + S1, S2 : INTEGER; + A1, A2, A3 : STRING (1 .. IDENT_INT (3)); + + TYPE REC IS RECORD + C1, C2 : INTEGER := 1; + END RECORD; + + R1, R2 : REC; + + PACKAGE P IS + TYPE PRIV IS PRIVATE; + PROCEDURE SET_PRIV (P : IN OUT PRIV); + PRIVATE + TYPE PRIV IS NEW REC; + END P; + USE P; + + P1, P2 : PRIV; + EX : EXCEPTION; + + GENERIC + TYPE T IS PRIVATE; + P1 : IN OUT T; + P2 : IN T; + PROCEDURE GP; + + B_ARR : ARRAY (1..10) OF BOOLEAN; + + PACKAGE BODY P IS + PROCEDURE SET_PRIV (P : IN OUT PRIV) IS + BEGIN + P.C1 := 3; + END SET_PRIV; + END P; + + PROCEDURE GP IS + BEGIN + IF P1 = P2 THEN + FAILED ("PARAMETER SCREW_UP SOMEWHERE"); + END IF; + P1 := P2; + IF P1 /= P2 THEN + FAILED ("ASSIGNMENT SCREW_UP SOMEWHERE"); + END IF; + RAISE EX; + FAILED ("RAISE STATEMENT DOESN'T WORK"); + END GP; + BEGIN + S1 := 4; + S2 := 5; + A1 := "XYZ"; + A2 := "ABC"; + A3 := "DEF"; + R1.C1 := 4; + R2.C1 := 5; + B_ARR := (1|3|5|7|9 => TRUE, 2|4|6|8|10 => FALSE); + SET_PRIV (P2); + + IF S1 = S2 + OR A1 = A3 + OR R1 = R2 + OR P1 = P2 THEN + FAILED ("WRONG ASSIGNMENT"); + END IF; + BEGIN + DECLARE + PROCEDURE PR IS NEW GP (INTEGER, S1, S2); + BEGIN + S2 := S1; + PR; -- OLD S2 ASSIGNED TO S1, SO S1 /= S2 NOW + FAILED ("EX NOT RAISED 1"); + EXCEPTION + WHEN EX => NULL; + END; + + DECLARE + SUBTYPE STR_1_3 IS STRING (IDENT_INT (1)..3); + PROCEDURE PR IS NEW GP (STR_1_3, A1, A3); + BEGIN + A3 := A1; + PR; + FAILED ("EX NOT RAISED 2"); + EXCEPTION + WHEN EX => NULL; + END; + + DECLARE + PROCEDURE PR IS NEW GP (REC, R1, R2); + BEGIN + R2 := R1; + PR; + FAILED ("EX NOT RAISED 3"); + EXCEPTION + WHEN EX => NULL; + END; + + DECLARE + PROCEDURE PR IS NEW GP (PRIV, P1, P2); + BEGIN + P2 := P1; + PR; + FAILED ("EX NOT RAISED 4"); + EXCEPTION + WHEN EX => NULL; + END; + DECLARE + PROCEDURE PR IS NEW GP (CHARACTER, + A3(IDENT_INT(2)), + A3(IDENT_INT(3))); + BEGIN + A3(3) := A3(2); + PR; + FAILED ("EX NOT RAISED 5"); + EXCEPTION + WHEN EX => NULL; + END; + + DECLARE + PROCEDURE PR IS NEW GP (BOOLEAN, + B_ARR(IDENT_INT(2)), + B_ARR(IDENT_INT(3))); + BEGIN + B_ARR(3) := B_ARR(2); + PR; + FAILED ("EX NOT RAISED 6"); + EXCEPTION + WHEN EX => NULL; + END; + END; + + IF S1 = S2 + OR A1 = A2 + OR R1 = R2 + OR P1 = P2 + OR A3(2) = A3(3) + OR B_ARR(2) = B_ARR(3) THEN + FAILED ("ASSIGNMENT FAILED 2"); + END IF; + END; + + RESULT; +END CC3120A; diff --git a/gcc/testsuite/ada/acats/tests/cc/cc3120b.ada b/gcc/testsuite/ada/acats/tests/cc/cc3120b.ada new file mode 100644 index 000000000..d25f4443f --- /dev/null +++ b/gcc/testsuite/ada/acats/tests/cc/cc3120b.ada @@ -0,0 +1,146 @@ +-- CC3120B.ADA + +-- Grant of Unlimited Rights +-- +-- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687, +-- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained +-- unlimited rights in the software and documentation contained herein. +-- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making +-- this public release, the Government intends to confer upon all +-- recipients unlimited rights equal to those held by the Government. +-- These rights include rights to use, duplicate, release or disclose the +-- released technical data and computer software in whole or in part, in +-- any manner and for any purpose whatsoever, and to have or permit others +-- to do so. +-- +-- DISCLAIMER +-- +-- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR +-- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED +-- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF 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 TASKS ARE NOT COPIED AS GENERIC IN OUT PARMS. + +-- DAT 8/27/81 +-- SPS 4/6/82 +-- JBG 3/23/83 + +WITH REPORT; USE REPORT; + +PROCEDURE CC3120B IS +BEGIN + TEST ("CC3120B", "TASKS ARE NOT COPIED AS GENERIC PARAMETERS"); + + DECLARE + PACKAGE P IS + TYPE T IS LIMITED PRIVATE; + PROCEDURE UPDT (TPARM: IN T; I : IN OUT INTEGER); + PRIVATE + TASK TYPE T1 IS + ENTRY GET (I : OUT INTEGER); + ENTRY PUT (I : IN INTEGER); + END T1; + TYPE T IS RECORD + C : T1; + END RECORD; + END P; + USE P; + TT : T; + GENERIC + TYPE T IS LIMITED PRIVATE; + T1 : IN OUT T; + WITH PROCEDURE UPDT (TPARM : IN T; I: IN OUT INTEGER) + IS <> ; + PROCEDURE PR; + + PROCEDURE PR IS + I : INTEGER; + BEGIN + I := 5; + -- PR.I + -- UPDT.I UPDT.T1.I + -- 5 4 + UPDT (T1, I); + -- 4 5 + IF I /= 4 THEN + FAILED ("BAD VALUE 1"); + END IF; + I := 6; + -- 6 5 + UPDT (T1, I); + -- 5 6 + IF I /= 5 THEN + FAILED ("BAD VALUE 3"); + END IF; + RAISE TASKING_ERROR; + FAILED ("INCORRECT RAISE STATEMENT"); + END PR; + + PACKAGE BODY P IS + PROCEDURE UPDT (TPARM : IN T; I : IN OUT INTEGER) IS + V : INTEGER := I; + -- UPDT.I => V + -- T1.I => UPDT.I + -- V => T1.I + BEGIN + TPARM.C.GET (I); + TPARM.C.PUT (V); + END UPDT; + + TASK BODY T1 IS + I : INTEGER; + BEGIN + I := 1; + LOOP + SELECT + ACCEPT GET (I : OUT INTEGER) DO + I := T1.I; + END GET; + OR + ACCEPT PUT (I : IN INTEGER) DO + T1.I := I; + END PUT; + OR + TERMINATE; + END SELECT; + END LOOP; + END T1; + END P; + BEGIN + DECLARE + X : INTEGER := 2; + PROCEDURE PPP IS NEW PR (T, TT); + BEGIN + -- X + -- UPDT.I UPDT.T1.I + -- 2 1 + UPDT (TT, X); + -- 1 2 + X := X + 3; + -- 4 2 + UPDT (TT, X); + -- 2 4 + IF X /= 2 THEN + FAILED ("WRONG VALUE FOR X"); + END IF; + BEGIN + PPP; + FAILED ("PPP NOT CALLED"); + EXCEPTION + WHEN TASKING_ERROR => NULL; + END; + X := 12; + -- 12 6 + UPDT (TT, X); + -- 6 12 + IF X /= 6 THEN + FAILED ("WRONG FINAL VALUE IN TASK"); + END IF; + END; + END; + + RESULT; +END CC3120B; diff --git a/gcc/testsuite/ada/acats/tests/cc/cc3121a.ada b/gcc/testsuite/ada/acats/tests/cc/cc3121a.ada new file mode 100644 index 000000000..a0a8e4aaf --- /dev/null +++ b/gcc/testsuite/ada/acats/tests/cc/cc3121a.ada @@ -0,0 +1,183 @@ +-- CC3121A.ADA + +-- Grant of Unlimited Rights +-- +-- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687, +-- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained +-- unlimited rights in the software and documentation contained herein. +-- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making +-- this public release, the Government intends to confer upon all +-- recipients unlimited rights equal to those held by the Government. +-- These rights include rights to use, duplicate, release or disclose the +-- released technical data and computer software in whole or in part, in +-- any manner and for any purpose whatsoever, and to have or permit others +-- to do so. +-- +-- DISCLAIMER +-- +-- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR +-- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED +-- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF 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 UNCONSTRAINED FORMAL GENERIC PARAMETER OF MODE "IN" +-- HAVING AN ARRAY TYPE OR A TYPE WITH DISCRIMINANTS HAS THE CONSTRAINTS +-- OF THE ACTUAL PARAMETER. + +-- TBN 9/29/86 + +WITH REPORT; USE REPORT; +PROCEDURE CC3121A IS + + SUBTYPE INT IS INTEGER RANGE 1 .. 10; + + TYPE ARRAY1 IS ARRAY (INT RANGE <>) OF INTEGER; + + TYPE REC1 (D : INT) IS + RECORD + VAR1 : INTEGER := 1; + END RECORD; + + TYPE REC2 (D : INT := 2) IS + RECORD + A : ARRAY1 (D .. IDENT_INT(4)); + B : REC1 (D); + C : INTEGER := 1; + END RECORD; + + TYPE ARRAY2 IS ARRAY (INT RANGE <>) OF REC2; + +BEGIN + TEST ("CC3121A", "CHECK THAT AN UNCONSTRAINED FORMAL GENERIC " & + "PARAMETER OF MODE 'IN' HAVING AN ARRAY TYPE " & + "OR A TYPE WITH DISCRIMINANTS HAS THE " & + "CONSTRAINTS OF THE ACTUAL PARAMETER"); + + DECLARE + OBJ_ARA1 : ARRAY1 (IDENT_INT(2) .. 5); + + GENERIC + VAR : ARRAY1; + PROCEDURE PROC; + + PROCEDURE PROC IS + BEGIN + IF VAR'FIRST /= IDENT_INT(2) THEN + FAILED ("INCORRECT RESULTS FOR VAR'FIRST"); + END IF; + IF VAR'LAST /= IDENT_INT(5) THEN + FAILED ("INCORRECT RESULTS FOR VAR'LAST"); + END IF; + END PROC; + + PROCEDURE PROC1 IS NEW PROC (OBJ_ARA1); + BEGIN + PROC1; + END; + + ------------------------------------------------------------------- + DECLARE + OBJ_REC2 : REC2; + + GENERIC + VAR : REC2; + FUNCTION FUNC RETURN INTEGER; + + FUNCTION FUNC RETURN INTEGER IS + BEGIN + IF VAR.D /= IDENT_INT(2) THEN + FAILED ("INCORRECT RESULTS FROM VAR.D"); + END IF; + IF VAR.A'FIRST /= IDENT_INT(2) THEN + FAILED ("INCORRECT RESULTS FROM VAR.A'FIRST"); + END IF; + IF VAR.A'LAST /= IDENT_INT(4) THEN + FAILED ("INCORRECT RESULTS FROM VAR.A'LAST"); + END IF; + IF VAR.B.D /= IDENT_INT(2) THEN + FAILED ("INCORRECT RESULTS FROM VAR.B.D"); + END IF; + RETURN IDENT_INT(1); + END FUNC; + + FUNCTION FUNC1 IS NEW FUNC (OBJ_REC2); + + BEGIN + IF FUNC1 /= IDENT_INT(1) THEN + FAILED ("INCORRECT RESULTS FROM FUNC1 CALL"); + END IF; + END; + + ------------------------------------------------------------------- + DECLARE + OBJ_ARA2 : ARRAY2 (IDENT_INT(6) .. 8); + + GENERIC + VAR : ARRAY2; + PROCEDURE PROC; + + PROCEDURE PROC IS + BEGIN + IF VAR'FIRST /= IDENT_INT(6) THEN + FAILED ("INCORRECT RESULTS FOR VAR'FIRST"); + END IF; + IF VAR'LAST /= IDENT_INT(8) THEN + FAILED ("INCORRECT RESULTS FOR VAR'LAST"); + END IF; + IF VAR(6).D /= IDENT_INT(2) THEN + FAILED ("INCORRECT RESULTS FROM VAR(6).D"); + END IF; + IF VAR(6).A'FIRST /= IDENT_INT(2) THEN + FAILED ("INCORRECT RESULTS FROM VAR(6).A'FIRST"); + END IF; + IF VAR(6).A'LAST /= IDENT_INT(4) THEN + FAILED ("INCORRECT RESULTS FROM VAR(6).A'LAST"); + END IF; + IF VAR(6).B.D /= IDENT_INT(2) THEN + FAILED ("INCORRECT RESULTS FROM VAR(6).B.D"); + END IF; + END PROC; + + PROCEDURE PROC2 IS NEW PROC (OBJ_ARA2); + BEGIN + PROC2; + END; + + ------------------------------------------------------------------- + DECLARE + OBJ_REC3 : REC2 (3); + + GENERIC + VAR : REC2; + PACKAGE PAC IS + PAC_VAR : INTEGER := 1; + END PAC; + + PACKAGE BODY PAC IS + BEGIN + IF VAR.D /= IDENT_INT(3) THEN + FAILED ("INCORRECT RESULTS FROM VAR.D"); + END IF; + IF VAR.A'FIRST /= IDENT_INT(3) THEN + FAILED ("INCORRECT RESULTS FROM VAR.A'FIRST"); + END IF; + IF VAR.A'LAST /= IDENT_INT(4) THEN + FAILED ("INCORRECT RESULTS FROM VAR.A'LAST"); + END IF; + IF VAR.B.D /= IDENT_INT(3) THEN + FAILED ("INCORRECT RESULTS FROM VAR.B.D"); + END IF; + END PAC; + + PACKAGE PAC1 IS NEW PAC (OBJ_REC3); + + BEGIN + NULL; + END; + + ------------------------------------------------------------------- + + RESULT; +END CC3121A; diff --git a/gcc/testsuite/ada/acats/tests/cc/cc3123a.ada b/gcc/testsuite/ada/acats/tests/cc/cc3123a.ada new file mode 100644 index 000000000..917f5fd45 --- /dev/null +++ b/gcc/testsuite/ada/acats/tests/cc/cc3123a.ada @@ -0,0 +1,198 @@ +-- CC3123A.ADA + +-- Grant of Unlimited Rights +-- +-- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687, +-- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained +-- unlimited rights in the software and documentation contained herein. +-- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making +-- this public release, the Government intends to confer upon all +-- recipients unlimited rights equal to those held by the Government. +-- These rights include rights to use, duplicate, release or disclose the +-- released technical data and computer software in whole or in part, in +-- any manner and for any purpose whatsoever, and to have or permit others +-- to do so. +-- +-- DISCLAIMER +-- +-- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR +-- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED +-- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF 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 DEFAULT EXPRESSIONS FOR GENERIC IN PARAMETERS ARE ONLY +-- EVALUATED IF THERE ARE NO ACTUAL PARAMETERS. + +-- TBN 12/01/86 + +WITH REPORT; USE REPORT; +PROCEDURE CC3123A IS + +BEGIN + TEST ("CC3123A", "CHECK THAT DEFAULT EXPRESSIONS FOR GENERIC IN " & + "PARAMETERS ARE ONLY EVALUATED IF THERE ARE " & + "NO ACTUAL PARAMETERS"); + DECLARE + TYPE ENUM IS (I, II, III); + OBJ_INT : INTEGER := 1; + OBJ_ENUM : ENUM := I; + + GENERIC + GEN_INT : IN INTEGER := IDENT_INT(2); + GEN_BOOL : IN BOOLEAN := IDENT_BOOL(FALSE); + GEN_ENUM : IN ENUM := II; + PACKAGE P IS + PAC_INT : INTEGER := GEN_INT; + PAC_BOOL : BOOLEAN := GEN_BOOL; + PAC_ENUM : ENUM := GEN_ENUM; + END P; + + PACKAGE P1 IS NEW P; + PACKAGE P2 IS + NEW P (IDENT_INT(OBJ_INT), GEN_ENUM => OBJ_ENUM); + PACKAGE P3 IS NEW P (GEN_BOOL => IDENT_BOOL(TRUE)); + BEGIN + IF P1.PAC_INT /= 2 OR P1.PAC_BOOL OR P1.PAC_ENUM /= II THEN + FAILED ("DEFAULT VALUES WERE NOT EVALUATED"); + END IF; + IF P2.PAC_INT /= 1 OR P2.PAC_BOOL OR P2.PAC_ENUM /= I THEN + FAILED ("DEFAULT VALUES WERE NOT EVALUATED CORRECTLY " & + "- 1"); + END IF; + IF P3.PAC_INT /= 2 OR NOT(P3.PAC_BOOL) OR + P3.PAC_ENUM /= II THEN + FAILED ("DEFAULT VALUES WERE NOT EVALUATED CORRECTLY " & + "- 2"); + END IF; + END; + + ------------------------------------------------------------------- + DECLARE + OBJ_INT1 : INTEGER := 3; + + FUNCTION FUNC (X : INTEGER) RETURN INTEGER; + + GENERIC + GEN_INT1 : IN INTEGER := FUNC (1); + GEN_INT2 : IN INTEGER := FUNC (GEN_INT1 + 1); + PROCEDURE PROC; + + PROCEDURE PROC IS + PROC_INT1 : INTEGER := GEN_INT1; + PROC_INT2 : INTEGER := GEN_INT2; + BEGIN + IF PROC_INT1 /= 3 THEN + FAILED ("DEFAULT VALUES WERE NOT EVALUATED " & + "CORRECTLY - 3"); + END IF; + IF PROC_INT2 /= 4 THEN + FAILED ("DEFAULT VALUES WERE NOT EVALUATED " & + "CORRECTLY - 4"); + END IF; + END PROC; + + FUNCTION FUNC (X : INTEGER) RETURN INTEGER IS + BEGIN + IF X /= IDENT_INT(4) THEN + FAILED ("DEFAULT VALUES WERE NOT EVALUATED " & + "CORRECTLY - 5"); + END IF; + RETURN IDENT_INT(X); + END FUNC; + + PROCEDURE NEW_PROC IS NEW PROC (GEN_INT1 => OBJ_INT1); + + BEGIN + NEW_PROC; + END; + + ------------------------------------------------------------------- + DECLARE + TYPE ARA_TYP IS ARRAY (1 .. 2) OF INTEGER; + TYPE REC IS + RECORD + ANS : BOOLEAN; + ARA : ARA_TYP; + END RECORD; + TYPE ARA_REC IS ARRAY (1 .. 5) OF REC; + + FUNCTION F (X : INTEGER) RETURN INTEGER; + + OBJ_REC : REC := (FALSE, (3, 4)); + OBJ_ARA : ARA_REC := (1 .. 5 => (FALSE, (3, 4))); + + GENERIC + GEN_OBJ1 : IN ARA_TYP := (F(1), 2); + GEN_OBJ2 : IN REC := (TRUE, GEN_OBJ1); + GEN_OBJ3 : IN ARA_REC := (1 .. F(5) => (TRUE, (1, 2))); + FUNCTION FUNC RETURN INTEGER; + + FUNCTION FUNC RETURN INTEGER IS + BEGIN + RETURN IDENT_INT(1); + END FUNC; + + FUNCTION F (X : INTEGER) RETURN INTEGER IS + BEGIN + FAILED ("DEFAULT VALUES WERE EVALUATED - 1"); + RETURN IDENT_INT(X); + END F; + + FUNCTION NEW_FUNC IS NEW FUNC ((3, 4), OBJ_REC, OBJ_ARA); + + BEGIN + IF NOT EQUAL (NEW_FUNC, 1) THEN + FAILED ("INCORRECT RESULT FROM GENERIC FUNCTION - 1"); + END IF; + END; + + ------------------------------------------------------------------- + DECLARE + SUBTYPE INT IS INTEGER RANGE 1 .. 5; + TYPE ARA_TYP IS ARRAY (1 .. 2) OF INTEGER; + TYPE COLOR IS (RED, WHITE); + TYPE CON_REC (D : INT) IS + RECORD + A : COLOR; + B : ARA_TYP; + END RECORD; + TYPE UNCON_OR_CON_REC (D : INT := 2) IS + RECORD + A : COLOR; + B : ARA_TYP; + END RECORD; + FUNCTION F (X : COLOR) RETURN COLOR; + + OBJ_CON1 : CON_REC (1) := (1, WHITE, (3, 4)); + OBJ_UNCON : UNCON_OR_CON_REC := (2, WHITE, (3, 4)); + OBJ_CON2 : UNCON_OR_CON_REC (3) := (3, WHITE, (3, 4)); + + GENERIC + GEN_CON1 : IN CON_REC := (2, F(RED), (1, 2)); + GEN_UNCON : IN UNCON_OR_CON_REC := (2, F(RED), (1, 2)); + GEN_CON2 : IN UNCON_OR_CON_REC := GEN_UNCON; + FUNCTION FUNC RETURN INTEGER; + + FUNCTION FUNC RETURN INTEGER IS + BEGIN + RETURN IDENT_INT(1); + END FUNC; + + FUNCTION F (X : COLOR) RETURN COLOR IS + BEGIN + FAILED ("DEFAULT VALUES WERE EVALUATED - 2"); + RETURN WHITE; + END F; + + FUNCTION NEW_FUNC IS NEW FUNC (OBJ_CON1, OBJ_UNCON, OBJ_CON2); + + BEGIN + IF NOT EQUAL (NEW_FUNC, 1) THEN + FAILED ("INCORRECT RESULT FROM GENERIC FUNCTION - 2"); + END IF; + END; + + RESULT; +END CC3123A; diff --git a/gcc/testsuite/ada/acats/tests/cc/cc3125a.ada b/gcc/testsuite/ada/acats/tests/cc/cc3125a.ada new file mode 100644 index 000000000..4adff6d2d --- /dev/null +++ b/gcc/testsuite/ada/acats/tests/cc/cc3125a.ada @@ -0,0 +1,111 @@ +-- CC3125A.ADA + +-- Grant of Unlimited Rights +-- +-- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687, +-- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained +-- unlimited rights in the software and documentation contained herein. +-- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making +-- this public release, the Government intends to confer upon all +-- recipients unlimited rights equal to those held by the Government. +-- These rights include rights to use, duplicate, release or disclose the +-- released technical data and computer software in whole or in part, in +-- any manner and for any purpose whatsoever, and to have or permit others +-- to do so. +-- +-- DISCLAIMER +-- +-- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR +-- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED +-- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE +-- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE +-- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A +-- PARTICULAR PURPOSE OF SAID MATERIAL. +--* +-- CHECK THAT CONSTRAINT_ERROR IS RAISED IF THE INITIAL VALUE OF A +-- GENERIC IN PARAMETER DOES NOT SATISFY ITS SUBTYPE CONSTRAINT. + +-- THIS TEST CHECKS PARAMETERS OF A NON-GENERIC TYPE. + +-- DAT 8/10/81 +-- SPS 4/14/82 + +WITH REPORT; USE REPORT; + +PROCEDURE CC3125A IS + +BEGIN + TEST ("CC3125A","GENERIC PARAMETER DEFAULTS OF " & + "NON-GENERIC TYPE EVALUATED AND CHECKED WHEN " & + "DECLARATION IS INSTANTIATED AND DEFAULT USED"); + + FOR I IN 1 .. 3 LOOP + COMMENT ("LOOP ITERATION"); + BEGIN + + DECLARE + SUBTYPE T IS INTEGER RANGE 1 .. IDENT_INT(1); + SUBTYPE I_1_2 IS INTEGER RANGE + IDENT_INT (1) .. IDENT_INT (2); + + GENERIC + P,Q : T := I_1_2'(I); + PACKAGE PKG IS + R: T := P; + END PKG; + + BEGIN + + BEGIN + DECLARE + PACKAGE P1 IS NEW PKG; + BEGIN + IF I = IDENT_INT(1) THEN + IF P1.R /= IDENT_INT(1) + THEN FAILED ("BAD INITIAL"& + " VALUE"); + END IF; + ELSIF I = 2 THEN + FAILED ("SUBTYPE NOT CHECKED AT " & + "INSTANTIATION"); + ELSE + FAILED ("DEFAULT NOT EVALUATED AT " & + "INSTANTIATION"); + END IF; + EXCEPTION + WHEN OTHERS => FAILED ("WRONG HANDLER"); + END; + EXCEPTION + WHEN CONSTRAINT_ERROR => + CASE I IS + WHEN 1 => + FAILED ("INCORRECT EXCEPTION"); + WHEN 2 => + COMMENT ("CONSTRAINT CHECKED" & + " ON INSTANTIATION"); + WHEN 3 => + COMMENT ("DEFAULT EVALUATED " & + "ON INSTANTIATION"); + END CASE; + END; + EXCEPTION + WHEN OTHERS => + FAILED ("WRONG EXCEPTION"); + END; + EXCEPTION + WHEN CONSTRAINT_ERROR => + CASE I IS + WHEN 1 => + FAILED ("NO EXCEPTION SHOULD BE RAISED"); + WHEN 2 => + FAILED ("DEFAULT CHECKED AGAINST " & + "SUBTYPE AT DECLARATION"); + WHEN 3 => + FAILED ("DEFAULT EVALUATED AT " & + "DECLARATION"); + END CASE; + END; + END LOOP; + + RESULT; +END CC3125A; diff --git a/gcc/testsuite/ada/acats/tests/cc/cc3125b.ada b/gcc/testsuite/ada/acats/tests/cc/cc3125b.ada new file mode 100644 index 000000000..84d6d1198 --- /dev/null +++ b/gcc/testsuite/ada/acats/tests/cc/cc3125b.ada @@ -0,0 +1,148 @@ +-- CC3125B.ADA + +-- Grant of Unlimited Rights +-- +-- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687, +-- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained +-- unlimited rights in the software and documentation contained herein. +-- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making +-- this public release, the Government intends to confer upon all +-- recipients unlimited rights equal to those held by the Government. +-- These rights include rights to use, duplicate, release or disclose the +-- released technical data and computer software in whole or in part, in +-- any manner and for any purpose whatsoever, and to have or permit others +-- to do so. +-- +-- DISCLAIMER +-- +-- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR +-- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED +-- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE +-- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE +-- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A +-- PARTICULAR PURPOSE OF SAID MATERIAL. +--* +-- CHECK THAT CONSTRAINT_ERROR IS RAISED FOR A GENERIC IN PARAMETER +-- HAVING AN ENUMERATION TYPE IF AND ONLY IF THE VALUE OF THE ACTUAL +-- PARAMETER LIES OUTSIDE THE RANGE OF THE FORMAL PARAMETER. + +-- TBN 12/15/86 + +WITH REPORT; USE REPORT; +PROCEDURE CC3125B IS + + TYPE COLOR IS (GREEN, RED, WHITE, BLUE, ORANGE, PINK); + SUBTYPE FLAG IS COLOR RANGE RED .. BLUE; + + FUNCTION IDENT_COL (X : COLOR) RETURN COLOR IS + BEGIN + IF EQUAL (3, 3) THEN + RETURN X; + END IF; + RETURN GREEN; + END IDENT_COL; + +BEGIN + TEST ("CC3125B", "CHECK THAT CONSTRAINT_ERROR IS RAISED FOR A " & + "GENERIC IN PARAMETER HAVING AN ENUMERATION " & + "TYPE IF AND ONLY IF THE VALUE OF THE ACTUAL " & + "PARAMETER LIES OUTSIDE THE RANGE OF THE " & + "FORMAL PARAMETER"); + DECLARE + GENERIC + GEN_COL : IN FLAG; + PACKAGE P IS + PAC_COL : FLAG := GEN_COL; + END P; + BEGIN + BEGIN + DECLARE + PACKAGE P1 IS NEW P(IDENT_COL(RED)); + BEGIN + IF P1.PAC_COL /= IDENT_COL(RED) THEN + FAILED ("INCORRECT VALUE PASSED - 1"); + END IF; + END; + EXCEPTION + WHEN OTHERS => + FAILED ("EXCEPTION RAISED - 1"); + END; + + BEGIN + DECLARE + PACKAGE P2 IS NEW P(IDENT_COL(GREEN)); + BEGIN + FAILED ("NO EXCEPTION RAISED - 2"); + END; + EXCEPTION + WHEN CONSTRAINT_ERROR => + NULL; + WHEN OTHERS => + FAILED ("UNEXPECTED EXCEPTION RAISED - 2"); + END; + + BEGIN + DECLARE + PACKAGE P3 IS NEW P(IDENT_COL(PINK)); + BEGIN + FAILED ("NO EXCEPTION RAISED - 3"); + END; + EXCEPTION + WHEN CONSTRAINT_ERROR => + NULL; + WHEN OTHERS => + FAILED ("UNEXPECTED EXCEPTION RAISED - 3"); + END; + END; + ------------------------------------------------------------------- + + DECLARE + GENERIC + TYPE GEN_TYP IS (<>); + GEN_COL : IN GEN_TYP; + PACKAGE Q IS + PAC_COL : GEN_TYP := GEN_COL; + END Q; + BEGIN + BEGIN + DECLARE + PACKAGE Q1 IS NEW Q(FLAG, IDENT_COL(BLUE)); + BEGIN + IF Q1.PAC_COL /= IDENT_COL(BLUE) THEN + FAILED ("INCORRECT VALUE PASSED - 4"); + END IF; + END; + EXCEPTION + WHEN OTHERS => + FAILED ("EXCEPTION RAISED - 4"); + END; + + BEGIN + DECLARE + PACKAGE Q2 IS NEW Q(FLAG, IDENT_COL(GREEN)); + BEGIN + FAILED ("NO EXCEPTION RAISED - 5"); + END; + EXCEPTION + WHEN CONSTRAINT_ERROR => + NULL; + WHEN OTHERS => + FAILED ("UNEXPECTED EXCEPTION RAISED - 5"); + END; + + BEGIN + DECLARE + PACKAGE Q3 IS NEW Q(FLAG, IDENT_COL(PINK)); + BEGIN + FAILED ("NO EXCEPTION RAISED - 6"); + END; + EXCEPTION + WHEN CONSTRAINT_ERROR => + NULL; + WHEN OTHERS => + FAILED ("UNEXPECTED EXCEPTION RAISED - 6"); + END; + END; + + RESULT; +END CC3125B; diff --git a/gcc/testsuite/ada/acats/tests/cc/cc3125c.ada b/gcc/testsuite/ada/acats/tests/cc/cc3125c.ada new file mode 100644 index 000000000..42904bdfb --- /dev/null +++ b/gcc/testsuite/ada/acats/tests/cc/cc3125c.ada @@ -0,0 +1,148 @@ +-- CC3125C.ADA + +-- Grant of Unlimited Rights +-- +-- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687, +-- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained +-- unlimited rights in the software and documentation contained herein. +-- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making +-- this public release, the Government intends to confer upon all +-- recipients unlimited rights equal to those held by the Government. +-- These rights include rights to use, duplicate, release or disclose the +-- released technical data and computer software in whole or in part, in +-- any manner and for any purpose whatsoever, and to have or permit others +-- to do so. +-- +-- DISCLAIMER +-- +-- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR +-- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED +-- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE +-- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE +-- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A +-- PARTICULAR PURPOSE OF SAID MATERIAL. +--* +-- CHECK THAT CONSTRAINT_ERROR IS RAISED FOR A GENERIC IN PARAMETER +-- HAVING A FLOATING POINT TYPE IF AND ONLY IF THE VALUE OF THE ACTUAL +-- PARAMETER LIES OUTSIDE THE RANGE OF THE FORMAL PARAMETER. + +-- TBN 12/15/86 + +WITH REPORT; USE REPORT; +PROCEDURE CC3125C IS + + TYPE FLT IS DIGITS 5 RANGE -10.0 .. 10.0; + SUBTYPE FLO IS FLT RANGE -5.0 .. 5.0; + + FUNCTION IDENT_FLT (X : FLT) RETURN FLT IS + BEGIN + IF EQUAL (3, 3) THEN + RETURN X; + END IF; + RETURN 0.0; + END IDENT_FLT; + +BEGIN + TEST ("CC3125C", "CHECK THAT CONSTRAINT_ERROR IS RAISED FOR A " & + "GENERIC IN PARAMETER HAVING A FLOATING POINT " & + "TYPE IF AND ONLY IF THE VALUE OF THE ACTUAL " & + "PARAMETER LIES OUTSIDE THE RANGE OF THE " & + "FORMAL PARAMETER"); + DECLARE + GENERIC + GEN_FLO : IN FLO; + PACKAGE P IS + PAC_FLO : FLT := GEN_FLO; + END P; + BEGIN + BEGIN + DECLARE + PACKAGE P1 IS NEW P(IDENT_FLT(-5.0)); + BEGIN + IF P1.PAC_FLO /= IDENT_FLT(-5.0) THEN + FAILED ("INCORRECT VALUE PASSED - 1"); + END IF; + END; + EXCEPTION + WHEN OTHERS => + FAILED ("EXCEPTION RAISED - 1"); + END; + + BEGIN + DECLARE + PACKAGE P2 IS NEW P(IDENT_FLT(-5.1)); + BEGIN + FAILED ("NO EXCEPTION RAISED - 2"); + END; + EXCEPTION + WHEN CONSTRAINT_ERROR => + NULL; + WHEN OTHERS => + FAILED ("UNEXPECTED EXCEPTION RAISED - 2"); + END; + + BEGIN + DECLARE + PACKAGE P3 IS NEW P(IDENT_FLT(5.1)); + BEGIN + FAILED ("NO EXCEPTION RAISED - 3"); + END; + EXCEPTION + WHEN CONSTRAINT_ERROR => + NULL; + WHEN OTHERS => + FAILED ("UNEXPECTED EXCEPTION RAISED - 3"); + END; + END; + ------------------------------------------------------------------- + + DECLARE + GENERIC + TYPE GEN_TYP IS DIGITS <>; + GEN_FLO : IN GEN_TYP; + PACKAGE Q IS + PAC_FLO : GEN_TYP := GEN_FLO; + END Q; + BEGIN + BEGIN + DECLARE + PACKAGE Q1 IS NEW Q(FLO, IDENT_FLT(5.0)); + BEGIN + IF Q1.PAC_FLO /= IDENT_FLT(5.0) THEN + FAILED ("INCORRECT VALUE PASSED - 4"); + END IF; + END; + EXCEPTION + WHEN OTHERS => + FAILED ("EXCEPTION RAISED - 4"); + END; + + BEGIN + DECLARE + PACKAGE Q2 IS NEW Q(FLO, IDENT_FLT(-5.1)); + BEGIN + FAILED ("NO EXCEPTION RAISED - 5"); + END; + EXCEPTION + WHEN CONSTRAINT_ERROR => + NULL; + WHEN OTHERS => + FAILED ("UNEXPECTED EXCEPTION RAISED - 5"); + END; + + BEGIN + DECLARE + PACKAGE Q3 IS NEW Q(FLO, IDENT_FLT(5.1)); + BEGIN + FAILED ("NO EXCEPTION RAISED - 6"); + END; + EXCEPTION + WHEN CONSTRAINT_ERROR => + NULL; + WHEN OTHERS => + FAILED ("UNEXPECTED EXCEPTION RAISED - 6"); + END; + END; + + RESULT; +END CC3125C; diff --git a/gcc/testsuite/ada/acats/tests/cc/cc3125d.ada b/gcc/testsuite/ada/acats/tests/cc/cc3125d.ada new file mode 100644 index 000000000..5977eb91a --- /dev/null +++ b/gcc/testsuite/ada/acats/tests/cc/cc3125d.ada @@ -0,0 +1,148 @@ +-- CC3125D.ADA + +-- Grant of Unlimited Rights +-- +-- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687, +-- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained +-- unlimited rights in the software and documentation contained herein. +-- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making +-- this public release, the Government intends to confer upon all +-- recipients unlimited rights equal to those held by the Government. +-- These rights include rights to use, duplicate, release or disclose the +-- released technical data and computer software in whole or in part, in +-- any manner and for any purpose whatsoever, and to have or permit others +-- to do so. +-- +-- DISCLAIMER +-- +-- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR +-- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED +-- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE +-- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE +-- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A +-- PARTICULAR PURPOSE OF SAID MATERIAL. +--* +-- CHECK THAT CONSTRAINT_ERROR IS RAISED FOR A GENERIC IN PARAMETER +-- HAVING A FIXED POINT TYPE IF AND ONLY IF THE VALUE OF THE ACTUAL +-- PARAMETER LIES OUTSIDE THE RANGE OF THE FORMAL PARAMETER. + +-- TBN 12/15/86 + +WITH REPORT; USE REPORT; +PROCEDURE CC3125D IS + + TYPE FIXED IS DELTA 0.125 RANGE -10.0 .. 10.0; + SUBTYPE FIX IS FIXED RANGE -5.0 .. 5.0; + + FUNCTION IDENT_FIX (X : FIXED) RETURN FIXED IS + BEGIN + IF EQUAL (3, 3) THEN + RETURN X; + END IF; + RETURN 0.0; + END IDENT_FIX; + +BEGIN + TEST ("CC3125D", "CHECK THAT CONSTRAINT_ERROR IS RAISED FOR A " & + "GENERIC IN PARAMETER HAVING A FIXED POINT " & + "TYPE IF AND ONLY IF THE VALUE OF THE ACTUAL " & + "PARAMETER LIES OUTSIDE THE RANGE OF THE " & + "FORMAL PARAMETER"); + DECLARE + GENERIC + GEN_FIX : IN FIX; + PACKAGE P IS + PAC_FIX : FIXED := GEN_FIX; + END P; + BEGIN + BEGIN + DECLARE + PACKAGE P1 IS NEW P(IDENT_FIX(-5.0)); + BEGIN + IF P1.PAC_FIX /= IDENT_FIX(-5.0) THEN + FAILED ("INCORRECT VALUE PASSED - 1"); + END IF; + END; + EXCEPTION + WHEN OTHERS => + FAILED ("EXCEPTION RAISED - 1"); + END; + + BEGIN + DECLARE + PACKAGE P2 IS NEW P(IDENT_FIX(-5.2)); + BEGIN + FAILED ("NO EXCEPTION RAISED - 2"); + END; + EXCEPTION + WHEN CONSTRAINT_ERROR => + NULL; + WHEN OTHERS => + FAILED ("UNEXPECTED EXCEPTION RAISED - 2"); + END; + + BEGIN + DECLARE + PACKAGE P3 IS NEW P(IDENT_FIX(5.2)); + BEGIN + FAILED ("NO EXCEPTION RAISED - 3"); + END; + EXCEPTION + WHEN CONSTRAINT_ERROR => + NULL; + WHEN OTHERS => + FAILED ("UNEXPECTED EXCEPTION RAISED - 3"); + END; + END; + ------------------------------------------------------------------- + + DECLARE + GENERIC + TYPE GEN_TYP IS DELTA <>; + GEN_FIX : IN GEN_TYP; + PACKAGE Q IS + PAC_FIX : GEN_TYP := GEN_FIX; + END Q; + BEGIN + BEGIN + DECLARE + PACKAGE Q1 IS NEW Q(FIX, IDENT_FIX(5.0)); + BEGIN + IF Q1.PAC_FIX /= IDENT_FIX(5.0) THEN + FAILED ("INCORRECT VALUE PASSED - 4"); + END IF; + END; + EXCEPTION + WHEN OTHERS => + FAILED ("EXCEPTION RAISED - 4"); + END; + + BEGIN + DECLARE + PACKAGE Q2 IS NEW Q(FIX, IDENT_FIX(-5.2)); + BEGIN + FAILED ("NO EXCEPTION RAISED - 5"); + END; + EXCEPTION + WHEN CONSTRAINT_ERROR => + NULL; + WHEN OTHERS => + FAILED ("UNEXPECTED EXCEPTION RAISED - 5"); + END; + + BEGIN + DECLARE + PACKAGE Q3 IS NEW Q(FIX, IDENT_FIX(5.2)); + BEGIN + FAILED ("NO EXCEPTION RAISED - 6"); + END; + EXCEPTION + WHEN CONSTRAINT_ERROR => + NULL; + WHEN OTHERS => + FAILED ("UNEXPECTED EXCEPTION RAISED - 6"); + END; + END; + + RESULT; +END CC3125D; diff --git a/gcc/testsuite/ada/acats/tests/cc/cc3126a.ada b/gcc/testsuite/ada/acats/tests/cc/cc3126a.ada new file mode 100644 index 000000000..ba234648b --- /dev/null +++ b/gcc/testsuite/ada/acats/tests/cc/cc3126a.ada @@ -0,0 +1,188 @@ +-- CC3126A.ADA + +-- Grant of Unlimited Rights +-- +-- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687, +-- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained +-- unlimited rights in the software and documentation contained herein. +-- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making +-- this public release, the Government intends to confer upon all +-- recipients unlimited rights equal to those held by the Government. +-- These rights include rights to use, duplicate, release or disclose the +-- released technical data and computer software in whole or in part, in +-- any manner and for any purpose whatsoever, and to have or permit others +-- to do so. +-- +-- DISCLAIMER +-- +-- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR +-- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED +-- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE +-- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE +-- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A +-- PARTICULAR PURPOSE OF SAID MATERIAL. +--* +-- OBJECTIVE: +-- CHECK THAT CONSTRAINT_ERROR IS RAISED IF AND ONLY IF THE ACTUAL +-- PARAMETER DOES NOT HAVE THE SAME NUMBER OF COMPONENTS +-- (PER DIMENSION) AS THE FORMAL PARAMETER. ALSO THAT FOR NULL +-- ARRAYS NO ERROR IS RAISED. + +-- HISTORY: +-- LB 12/02/86 +-- DWC 08/11/87 CHANGED HEADING FORMAT. +-- RJW 10/26/89 INITIALIZED VARIABLE H. + +WITH REPORT; USE REPORT; + +PROCEDURE CC3126A IS + +BEGIN + TEST ("CC3126A","GENERIC ACTUAL PARAMETER MUST HAVE THE SAME "& + "NUMBER OF COMPONENTS (PER DIMENSION) AS THE "& + "GENERIC FORMAL PARMETER"); + BEGIN + DECLARE + TYPE ARRY1 IS ARRAY (INTEGER RANGE <>) OF INTEGER; + SUBTYPE ARR IS ARRY1 (1 .. 10); + + GENERIC + GARR : IN ARR; + PACKAGE P IS + NARR : ARR := GARR; + END P; + + BEGIN + BEGIN + DECLARE + X : ARRY1 (2 .. 11) := (2 .. 11 => 0); + PACKAGE Q IS NEW P(X); + BEGIN + Q.NARR(2) := 1; + END; + EXCEPTION + WHEN OTHERS => + FAILED ("EXCEPTION RAISED 1"); + END; + + BEGIN + DECLARE + S : ARRY1 (1 .. 11) := (1 .. 11 => 0); + PACKAGE R IS NEW P(S); + BEGIN + FAILED ("EXCEPTION NOT RAISED 2"); + R.NARR(1) := IDENT_INT(R.NARR(1)); + END; + EXCEPTION + WHEN CONSTRAINT_ERROR => + NULL; + WHEN OTHERS => + FAILED ("WRONG EXCEPTION RAISED 2"); + END; + + BEGIN + DECLARE + G : ARRY1 (1 .. 9) := (1 .. 9 => 0); + PACKAGE K IS NEW P(G); + BEGIN + FAILED ("EXCEPTION NOT RAISED 3"); + IF EQUAL(3,3) THEN + K.NARR(1) := IDENT_INT(K.NARR(1)); + END IF; + END; + EXCEPTION + WHEN CONSTRAINT_ERROR => + NULL; + WHEN OTHERS => + FAILED ("WRONG EXCEPTION RAISED 3"); + END; + + BEGIN + DECLARE + S : ARRY1 (1 .. 11) := (1 .. 11 => 0); + PACKAGE F IS NEW P(S(2 .. 11)); + BEGIN + F.NARR(2) := IDENT_INT(F.NARR(2)); + END; + EXCEPTION + WHEN OTHERS => + FAILED ("EXCEPTION RAISED 4"); + END; + END; + + DECLARE + SUBTYPE STR IS STRING(1 .. 20); + + GENERIC + GVAR : IN STR; + PACKAGE M IS + NVAR : STR := GVAR; + END M; + + BEGIN + BEGIN + DECLARE + L : STRING (2 .. 15); + PACKAGE U IS NEW M(L); + BEGIN + FAILED ("EXCEPTION NOT RAISED 5"); + U.NVAR(2) := IDENT_CHAR(U.NVAR(2)); + END; + EXCEPTION + WHEN CONSTRAINT_ERROR => + NULL; + WHEN OTHERS => + FAILED ("WRONG EXCEPTION RAISED 5"); + END; + + BEGIN + DECLARE + H : STRING (1 .. 20) := (OTHERS => 'R'); + PACKAGE J IS NEW M(H); + BEGIN + IF EQUAL(3,3) THEN + J.NVAR(2) := IDENT_CHAR(J.NVAR(2)); + END IF; + END; + EXCEPTION + WHEN OTHERS => + FAILED ("EXCEPTION RAISED 6"); + END; + EXCEPTION + WHEN OTHERS => + FAILED ("UNEXPECTED ERROR RAISED STRINGS"); + END; + + DECLARE + TYPE NARRY IS ARRAY (INTEGER RANGE <>) OF INTEGER; + SUBTYPE SNARRY IS NARRY (2 .. 0); + + GENERIC + RD : IN SNARRY; + PACKAGE JA IS + CD : SNARRY := RD; + END JA; + BEGIN + BEGIN + DECLARE + AD : NARRY(1 .. 0); + PACKAGE PA IS NEW JA(AD); + BEGIN + IF NOT EQUAL(0,PA.CD'LAST) THEN + FAILED ("PARAMETER ATTRIBUTE INCORRECT"); + END IF; + END; + EXCEPTION + WHEN OTHERS => + FAILED ("EXCEPTION RAISED 7"); + END; + EXCEPTION + WHEN OTHERS => + FAILED ("UNEXPECTED EXCEPTION RAISED FOR ARRAYS "& + "WITH NULL RANGES"); + END; + END; + + RESULT; + +END CC3126A; diff --git a/gcc/testsuite/ada/acats/tests/cc/cc3127a.ada b/gcc/testsuite/ada/acats/tests/cc/cc3127a.ada new file mode 100644 index 000000000..9e1ccdb68 --- /dev/null +++ b/gcc/testsuite/ada/acats/tests/cc/cc3127a.ada @@ -0,0 +1,143 @@ +-- CC3127A.ADA + +-- Grant of Unlimited Rights +-- +-- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687, +-- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained +-- unlimited rights in the software and documentation contained herein. +-- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making +-- this public release, the Government intends to confer upon all +-- recipients unlimited rights equal to those held by the Government. +-- These rights include rights to use, duplicate, release or disclose the +-- released technical data and computer software in whole or in part, in +-- any manner and for any purpose whatsoever, and to have or permit others +-- to do so. +-- +-- DISCLAIMER +-- +-- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR +-- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED +-- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF 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: +-- FOR A CONSTRAINED IN FORMAL PARAMETER HAVING A RECORD OR PRIVATE +-- TYPE WITH DISCRIMINANTS, CHECK THAT CONSTRAINT_ERROR IS RAISED +-- IF AND ONLY IF CORRESPONDING DISCRIMINANTS OF THE ACTUAL AND +-- FORMAL PARAMETER DO NOT HAVE THE SAME VALUES. + +-- HISTORY: +-- LB 12/04/86 CREATED ORIGINAL TEST. +-- VCL 08/19/87 CORRECTED THE FORMAT OF THIS HEADER. + +WITH REPORT; USE REPORT; + +PROCEDURE CC3127A IS + + TYPE INT IS RANGE 1 .. 20; + +BEGIN + TEST ("CC3127A","CORRESPONDING DISCRIMINANTS OF THE GENERIC "& + "ACTUAL PARAMETER AND THE GENERIC FORMAL "& + "PARAMETER MUST HAVE THE SAME VALUES."); + BEGIN + DECLARE + TYPE REC (A : INT) IS + RECORD + RINT : POSITIVE := 2; + END RECORD; + SUBTYPE CON_REC IS REC(4); + + GENERIC + GREC : IN CON_REC; + PACKAGE PA IS + NREC : CON_REC := GREC; + END PA; + BEGIN + BEGIN + DECLARE + RVAR : REC(3); + PACKAGE AB IS NEW PA(RVAR); + BEGIN + FAILED ("EXCEPTION NOT RAISED 1"); + AB.NREC.RINT := IDENT_INT(AB.NREC.RINT); + END; + EXCEPTION + WHEN CONSTRAINT_ERROR => + NULL; + WHEN OTHERS => + FAILED ("WRONG EXCEPTION RAISED 1"); + END; + + BEGIN + DECLARE + SVAR : REC(4); + PACKAGE CD IS NEW PA(SVAR); + BEGIN + IF EQUAL(3,3) THEN + CD.NREC.RINT := IDENT_INT(CD.NREC.RINT); + END IF; + END; + EXCEPTION + WHEN OTHERS => + FAILED ("EXCEPTION RAISED 2"); + END; + END; + + DECLARE + PACKAGE EF IS + TYPE PRI_REC (G : INT) IS PRIVATE; + PRIVATE + TYPE PRI_REC (G : INT) IS + RECORD + PINT : POSITIVE := 2; + END RECORD; + END EF; + SUBTYPE CPRI_REC IS EF.PRI_REC(4); + + GENERIC + GEN_REC : IN CPRI_REC; + PACKAGE GH IS + NGEN_REC : CPRI_REC := GEN_REC; + END GH; + + BEGIN + BEGIN + DECLARE + PVAR : EF.PRI_REC(4); + PACKAGE LM IS NEW GH(PVAR); + BEGIN + IF EQUAL(3,3) THEN + LM.NGEN_REC := LM.NGEN_REC; + END IF; + END; + EXCEPTION + WHEN OTHERS => + FAILED ("EXCEPTION RAISED 3"); + END; + + BEGIN + DECLARE + PTVAR : EF.PRI_REC(5); + PACKAGE PAC IS NEW GH(PTVAR); + BEGIN + FAILED ("EXCEPTION NOT RAISED 4"); + IF EQUAL(3,5) THEN + COMMENT ("DISCRIMINANT OF PAC.NGEN_REC IS "& + INT'IMAGE(PAC.NGEN_REC.G)); + END IF; + END; + EXCEPTION + WHEN CONSTRAINT_ERROR => + NULL; + WHEN OTHERS => + FAILED ("WRONG EXCEPTION RAISED 4"); + END; + END; + END; + + RESULT; + +END CC3127A; diff --git a/gcc/testsuite/ada/acats/tests/cc/cc3128a.ada b/gcc/testsuite/ada/acats/tests/cc/cc3128a.ada new file mode 100644 index 000000000..9afdd77d2 --- /dev/null +++ b/gcc/testsuite/ada/acats/tests/cc/cc3128a.ada @@ -0,0 +1,358 @@ +-- CC3128A.ADA + +-- Grant of Unlimited Rights +-- +-- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687, +-- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained +-- unlimited rights in the software and documentation contained herein. +-- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making +-- this public release, the Government intends to confer upon all +-- recipients unlimited rights equal to those held by the Government. +-- These rights include rights to use, duplicate, release or disclose the +-- released technical data and computer software in whole or in part, in +-- any manner and for any purpose whatsoever, and to have or permit others +-- to do so. +-- +-- DISCLAIMER +-- +-- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR +-- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED +-- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF 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 CONSTRAINED IN FORMAL PARAMETER HAVING AN ACCESS TYPE, +-- CONSTRAINT_ERROR IS RAISED IF AND ONLY IF THE ACTUAL PARAMETER IS NOT +-- NULL AND THE OBJECT DESIGNATED BY THE ACTUAL PARAMETER DOES NOT SATISFY +-- THE FORMAL PARAMETER'S CONSTRAINTS. + +-- HISTORY: +-- RJW 10/28/88 CREATED ORIGINAL TEST. +-- JRL 02/28/96 Removed cases where the designated subtypes of the formal +-- and actual do not statically match. Corrected commentary. + +WITH REPORT; USE REPORT; +PROCEDURE CC3128A IS + +BEGIN + TEST ("CC3128A", "FOR A CONSTRAINED IN FORMAL PARAMETER HAVING " & + "AN ACCESS TYPE, CONSTRAINT_ERROR IS RAISED " & + "IF AND ONLY IF THE ACTUAL PARAMETER IS NOT " & + "NULL AND THE OBJECT DESIGNATED BY THE ACTUAL " & + "PARAMETER DOES NOT SATISFY FORMAL PARAMETER'S " & + "CONSTRAINTS"); + + DECLARE + TYPE REC (D : INTEGER := 10) IS + RECORD + NULL; + END RECORD; + + TYPE ACCREC IS ACCESS REC; + + SUBTYPE LINK IS ACCREC (5); + + GENERIC + LINK1 : LINK; + FUNCTION F (I : INTEGER) RETURN INTEGER; + + FUNCTION F (I : INTEGER) RETURN INTEGER IS + BEGIN + IF I /= 5 THEN + FAILED ("CONSTRAINT_ERROR NOT RAISED PRIOR " & + "TO CALL TO FUNCTION F - 1"); + END IF; + IF NOT EQUAL (I, 5) AND THEN + NOT EQUAL (LINK1.D, LINK1.D) THEN + COMMENT ("DISREGARD"); + END IF; + RETURN I + 1; + EXCEPTION + WHEN OTHERS => + FAILED ("EXCEPTION RAISED WITHIN FUNCTION F - 1"); + RETURN I + 1; + END F; + + GENERIC + TYPE PRIV (D : INTEGER) IS PRIVATE; + PRIV1 : PRIV; + PACKAGE GEN IS + TYPE ACCPRIV IS ACCESS PRIV; + SUBTYPE LINK IS ACCPRIV (5); + GENERIC + LINK1 : LINK; + I : IN OUT INTEGER; + PACKAGE P IS END P; + END GEN; + + PACKAGE BODY GEN IS + PACKAGE BODY P IS + BEGIN + IF I /= 5 THEN + FAILED ("CONSTRAINT_ERROR NOT RAISED PRIOR " & + "TO PACKAGE BODY P - 1"); + END IF; + IF NOT EQUAL (I, 5) AND THEN + NOT EQUAL (LINK1.D, LINK1.D) THEN + COMMENT ("DISREGARD"); + END IF; + I := I + 1; + EXCEPTION + WHEN OTHERS => + FAILED ("EXCEPTION RAISED WITHIN " & + "PACKAGE P - 1"); + I := I + 1; + END P; + + BEGIN + BEGIN + DECLARE + AR10 : ACCPRIV; + I : INTEGER := IDENT_INT (5); + PACKAGE P1 IS NEW P (AR10, I); + BEGIN + IF I /= 6 THEN + FAILED ("INCORRECT RESULT - " & + "PACKAGE P1"); + END IF; + EXCEPTION + WHEN OTHERS => + FAILED ("EXCEPTION RAISED TOO LATE - " & + "PACKAGE P1 - 1"); + END; + EXCEPTION + WHEN OTHERS => + FAILED ("EXCEPTION RAISED AT INSTANTIATION " & + "OF PACKAGE P1 WITH NULL ACCESS " & + "VALUE"); + END; + + BEGIN + DECLARE + AR10 : ACCPRIV := NEW PRIV'(PRIV1); + I : INTEGER := IDENT_INT (0); + PACKAGE P1 IS NEW P (AR10, I); + BEGIN + FAILED ("NO EXCEPTION RAISED BY " & + "INSTANTIATION OF PACKAGE P1"); + EXCEPTION + WHEN OTHERS => + FAILED ("EXCEPTION RAISED TOO LATE - " & + "PACKAGE P1 - 2"); + END; + EXCEPTION + WHEN CONSTRAINT_ERROR => + NULL; + WHEN OTHERS => + FAILED ("WRONG EXCEPTION RAISED AT " & + "INSTANTIATION OF PACKAGE P1"); + END; + END GEN; + + PACKAGE NEWGEN IS NEW GEN (REC, (D => 10)); + + BEGIN + BEGIN + DECLARE + I : INTEGER := IDENT_INT (5); + AR10 : ACCREC; + FUNCTION F1 IS NEW F (AR10); + BEGIN + I := F1 (I); + IF I /= 6 THEN + FAILED ("INCORRECT RESULT RETURNED BY " & + "FUNCTION F1"); + END IF; + EXCEPTION + WHEN OTHERS => + FAILED ("EXCEPTION RAISED AT CALL TO " & + "FUNCTION F1 - 1"); + END; + EXCEPTION + WHEN OTHERS => + FAILED ("EXCEPTION RAISED AT INSTANTIATION OF " & + "FUNCTION F1 WITH NULL ACCESS VALUE"); + END; + + BEGIN + DECLARE + I : INTEGER := IDENT_INT (0); + AR10 : ACCREC := NEW REC'(D => 10); + FUNCTION F1 IS NEW F (AR10); + BEGIN + FAILED ("NO EXCEPTION RAISED BY INSTANTIATION " & + "OF FUNCTION F1"); + I := F1 (I); + EXCEPTION + WHEN OTHERS => + FAILED ("EXCEPTION RAISED AT CALL TO " & + "FUNCTION F1 - 2"); + END; + EXCEPTION + WHEN CONSTRAINT_ERROR => + NULL; + WHEN OTHERS => + FAILED ("WRONG EXCEPTION RAISED AT " & + "INSTANTIATION OF FUNCTION F1"); + END; + END; + + DECLARE + TYPE ARR IS ARRAY (POSITIVE RANGE <>) OF INTEGER; + + TYPE ACCARR IS ACCESS ARR; + + SUBTYPE LINK IS ACCARR (1 .. 5); + + GENERIC + LINK1 : LINK; + FUNCTION F (I : INTEGER) RETURN INTEGER; + + FUNCTION F (I : INTEGER) RETURN INTEGER IS + BEGIN + IF I /= 5 THEN + FAILED ("CONSTRAINT_ERROR NOT RAISED PRIOR " & + "TO CALL TO FUNCTION F - 2"); + END IF; + IF NOT EQUAL (I, 5) AND THEN + NOT EQUAL (LINK1(IDENT_INT (3)),LINK1(IDENT_INT (3))) + THEN + COMMENT ("DISREGARD"); + END IF; + RETURN I + 1; + EXCEPTION + WHEN OTHERS => + FAILED ("EXCEPTION RAISED WITHIN FUNCTION F - 2"); + RETURN I + 1; + END F; + + GENERIC + TYPE GENARR IS ARRAY (POSITIVE RANGE <>) OF INTEGER; + PACKAGE GEN IS + TYPE ACCGENARR IS ACCESS GENARR; + SUBTYPE LINK IS ACCGENARR (1 .. 5); + GENERIC + LINK1 : LINK; + I : IN OUT INTEGER; + PACKAGE P IS END P; + END GEN; + + PACKAGE BODY GEN IS + PACKAGE BODY P IS + BEGIN + IF I /= 5 THEN + FAILED ("CONSTRAINT_ERROR NOT RAISED PRIOR " & + "TO PACKAGE BODY P - 2"); + END IF; + IF NOT EQUAL (I, 5) AND THEN + NOT + EQUAL(LINK1(IDENT_INT (3)),LINK1(IDENT_INT (3))) + THEN + COMMENT ("DISREGARD"); + END IF; + I := I + 1; + EXCEPTION + WHEN OTHERS => + FAILED ("EXCEPTION RAISED WITHIN " & + "PACKAGE P - 2"); + I := I + 1; + END P; + + BEGIN + BEGIN + DECLARE + AR26 : ACCGENARR (2 .. 6); + I : INTEGER := IDENT_INT (5); + PACKAGE P2 IS NEW P (AR26, I); + BEGIN + IF I /= 6 THEN + FAILED ("INCORRECT RESULT - " & + "PACKAGE P2"); + END IF; + EXCEPTION + WHEN OTHERS => + FAILED ("EXCEPTION RAISED TOO LATE - " & + "PACKAGE P2 - 1"); + END; + EXCEPTION + WHEN OTHERS => + FAILED ("EXCEPTION RAISED AT INSTANTIATION " & + "OF PACKAGE P2 WITH NULL ACCESS " & + "VALUE"); + END; + + BEGIN + DECLARE + AR26 : ACCGENARR + (IDENT_INT (2) .. IDENT_INT (6)) := + NEW GENARR'(1,2,3,4,5); + I : INTEGER := IDENT_INT (0); + PACKAGE P2 IS NEW P (AR26, I); + BEGIN + FAILED ("NO EXCEPTION RAISED BY " & + "INSTANTIATION OF PACKAGE P2"); + EXCEPTION + WHEN OTHERS => + FAILED ("EXCEPTION RAISED TOO LATE - " & + "PACKAGE P2 - 2"); + END; + EXCEPTION + WHEN CONSTRAINT_ERROR => + NULL; + WHEN OTHERS => + FAILED ("WRONG EXCEPTION RAISED AT " & + "INSTANTIATION OF PACKAGE P2"); + END; + END GEN; + + PACKAGE NEWGEN IS NEW GEN (ARR); + + BEGIN + BEGIN + DECLARE + I : INTEGER := IDENT_INT (5); + AR26 : ACCARR (IDENT_INT (2) .. IDENT_INT (6)); + FUNCTION F2 IS NEW F (AR26); + BEGIN + I := F2 (I); + IF I /= 6 THEN + FAILED ("INCORRECT RESULT RETURNED BY " & + "FUNCTION F2"); + END IF; + EXCEPTION + WHEN OTHERS => + FAILED ("EXCEPTION RAISED AT CALL TO " & + "FUNCTION F2 - 1"); + END; + EXCEPTION + WHEN OTHERS => + FAILED ("EXCEPTION RAISED AT INSTANTIATION OF " & + "FUNCTION F2 WITH NULL ACCESS VALUE"); + END; + + BEGIN + DECLARE + I : INTEGER := IDENT_INT (0); + AR26 : ACCARR (2 .. 6) := NEW ARR'(1,2,3,4,5); + FUNCTION F2 IS NEW F (AR26); + BEGIN + FAILED ("NO EXCEPTION RAISED BY INSTANTIATION " & + "OF FUNCTION F2"); + I := F2 (I); + EXCEPTION + WHEN OTHERS => + FAILED ("EXCEPTION RAISED AT CALL TO " & + "FUNCTION F2 - 2"); + END; + EXCEPTION + WHEN CONSTRAINT_ERROR => + NULL; + WHEN OTHERS => + FAILED ("WRONG EXCEPTION RAISED AT " & + "INSTANTIATION OF FUNCTION F2"); + END; + END; + RESULT; +END CC3128A; diff --git a/gcc/testsuite/ada/acats/tests/cc/cc3203a.ada b/gcc/testsuite/ada/acats/tests/cc/cc3203a.ada new file mode 100644 index 000000000..b0228ea92 --- /dev/null +++ b/gcc/testsuite/ada/acats/tests/cc/cc3203a.ada @@ -0,0 +1,89 @@ +-- CC3203A.ADA + +-- Grant of Unlimited Rights +-- +-- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687, +-- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained +-- unlimited rights in the software and documentation contained herein. +-- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making +-- this public release, the Government intends to confer upon all +-- recipients unlimited rights equal to those held by the Government. +-- These rights include rights to use, duplicate, release or disclose the +-- released technical data and computer software in whole or in part, in +-- any manner and for any purpose whatsoever, and to have or permit others +-- to do so. +-- +-- DISCLAIMER +-- +-- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR +-- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED +-- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF 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 WHEN A GENERIC FORMAL LIMITED/NON LIMITED PRIVATE TYPE HAS +-- DISCRIMINANTS, THE ACTUAL PARAMETER CAN HAVE DEFAULT DISCRIMINANT +-- VALUES. + +-- SPS 7/9/82 + +WITH REPORT; +USE REPORT; + +PROCEDURE CC3203A IS +BEGIN + TEST ("CC3203A", "CHECK DEFAULT VALUES FOR LIMITED/" & + "NON LIMITED GENERIC FORMAL PRIVATE TYPES"); + DECLARE + SD : INTEGER := IDENT_INT(0); + + FUNCTION INIT_RC (X: INTEGER) RETURN INTEGER; + + TYPE REC (D : INTEGER := 3) IS + RECORD NULL; END RECORD; + + TYPE RC(C : INTEGER := INIT_RC (1)) IS + RECORD NULL; END RECORD; + + GENERIC + TYPE PV(X : INTEGER) IS PRIVATE; + TYPE LP(X : INTEGER) IS LIMITED PRIVATE; + PACKAGE PACK IS + SUBTYPE NPV IS PV; + SUBTYPE NLP IS LP; + END PACK; + + FUNCTION INIT_RC (X: INTEGER) RETURN INTEGER IS + BEGIN + SD := SD + X; + RETURN SD; + END INIT_RC; + + PACKAGE P1 IS NEW PACK (REC, RC); + + PACKAGE P2 IS + P1VP : P1.NPV; + P1VL : P1.NLP; + P1VL2 : P1.NLP; + END P2; + USE P2; + BEGIN + + IF P1VP.D /= IDENT_INT(3) THEN + FAILED ("DEFAULT DISCRIMINANT VALUE WRONG"); + END IF; + + IF P1VL.C /= 1 THEN + FAILED ("DID NOT EVALUATE DEFAULT DISCRIMINANT"); + END IF; + + IF P1VL2.C /= IDENT_INT(2) THEN + FAILED ("DID NOT EVALUATE DEFAULT DISCRIMINANT " & + "WHEN NEEDED"); + END IF; + END; + + RESULT; + +END CC3203A; diff --git a/gcc/testsuite/ada/acats/tests/cc/cc3207b.ada b/gcc/testsuite/ada/acats/tests/cc/cc3207b.ada new file mode 100644 index 000000000..8b6fa03ae --- /dev/null +++ b/gcc/testsuite/ada/acats/tests/cc/cc3207b.ada @@ -0,0 +1,119 @@ +-- CC3207B.ADA + +-- Grant of Unlimited Rights +-- +-- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687, +-- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained +-- unlimited rights in the software and documentation contained herein. +-- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making +-- this public release, the Government intends to confer upon all +-- recipients unlimited rights equal to those held by the Government. +-- These rights include rights to use, duplicate, release or disclose the +-- released technical data and computer software in whole or in part, in +-- any manner and for any purpose whatsoever, and to have or permit others +-- to do so. +-- +-- DISCLAIMER +-- +-- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR +-- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED +-- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF 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 INSTANTIATION IS LEGAL IF A FORMAL +-- PARAMETER HAVING A LIMITED PRIVATE TYPE WITHOUT +-- A DISCRIMINANT IS USED TO DECLARE AN ACCESS +-- TYPE IN A BLOCK THAT CONTAINS A SELECTIVE WAIT +-- WITH A TERMINATE ALTERNATIVE, AND ACTUAL +-- PARAMETER'S BASE IS A TASK TYPE OR TYPE WITH A +-- SUBCOMPONENT OF A TASK TYPE. + +-- HISTORY: +-- LDC 06/24/88 CREATED ORIGINAL TEST. + +WITH REPORT; +USE REPORT; + +PROCEDURE CC3207B IS +BEGIN + TEST("CC3207B","CHECK THAT INSTANTIATION IS LEGAL IF A " & + "FORMAL PARAMETER HAVING A LIMITED PRIVATE " & + "TYPE WITHOUT A DISCRIMINANT IS USED TO " & + "DECLARE AN ACCESS TYPE IN A BLOCK THAT " & + "CONTAINS A SELECTIVE WAIT WITH A TERMINATE " & + "ALTERNATIVE, AND ACTUAL PARAMETER'S BASE " & + "A TASK TYPE OR TYPE WITH A SUBCOMPONENT OF " & + "A TASK TYPE. "); + + DECLARE + TASK TYPE TT IS + ENTRY E; + END TT; + + TYPE TT_ARR IS ARRAY (1..2) OF TT; + + TYPE TT_REC IS RECORD + COMP : TT_ARR; + END RECORD; + + GENERIC + TYPE T IS LIMITED PRIVATE; + PACKAGE GEN IS + TASK TSK IS + ENTRY ENT(A : OUT INTEGER); + END TSK; + END GEN; + + INT : INTEGER; + + TASK BODY TT IS + BEGIN + SELECT + ACCEPT E; + OR + TERMINATE; + END SELECT; + END TT; + + PACKAGE BODY GEN IS + TASK BODY TSK IS + BEGIN + DECLARE + TYPE ACC_T IS ACCESS T; + TA : ACC_T := NEW T; + BEGIN + SELECT + ACCEPT ENT(A : OUT INTEGER) DO + A := IDENT_INT(7); + END; + OR + TERMINATE; + END SELECT; + END; + END TSK; + END GEN; + + PACKAGE GEN_TSK IS NEW GEN(TT); + PACKAGE GEN_TSK_SUB IS NEW GEN(TT_REC); + + BEGIN + GEN_TSK.TSK.ENT(INT); + + IF INT /= IDENT_INT(7) THEN + FAILED("THE WRONG VALUE WAS RETURNED BY THE TASK"); + END IF; + + INT := 0; + GEN_TSK_SUB.TSK.ENT(INT); + + IF INT /= IDENT_INT(7) THEN + FAILED("THE WRONG VALUE WAS RETURNED BY THE TASK, " & + "WITH ACTUAL PARAMETER'S BASE IS A SUB" & + "COMPONENT OF A TASK TYPE"); + END IF; + RESULT; + END; +END CC3207B; diff --git a/gcc/testsuite/ada/acats/tests/cc/cc3220a.ada b/gcc/testsuite/ada/acats/tests/cc/cc3220a.ada new file mode 100644 index 000000000..d80ec17ea --- /dev/null +++ b/gcc/testsuite/ada/acats/tests/cc/cc3220a.ada @@ -0,0 +1,163 @@ +-- CC3220A.ADA + +-- Grant of Unlimited Rights +-- +-- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687, +-- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained +-- unlimited rights in the software and documentation contained herein. +-- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making +-- this public release, the Government intends to confer upon all +-- recipients unlimited rights equal to those held by the Government. +-- These rights include rights to use, duplicate, release or disclose the +-- released technical data and computer software in whole or in part, in +-- any manner and for any purpose whatsoever, and to have or permit others +-- to do so. +-- +-- DISCLAIMER +-- +-- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR +-- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED +-- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF 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 DISCRETE FORMAL TYPE DENOTES ITS ACTUAL PARAMETER, AND +-- OPERATIONS OF THE FORMAL TYPE ARE IDENTIFIED WITH CORRESPONDING +-- OPERATIONS OF THE ACTUAL TYPE. + +-- TBN 10/08/86 + +WITH REPORT; USE REPORT; +PROCEDURE CC3220A IS + + GENERIC + TYPE T IS (<>); + PACKAGE P IS + SUBTYPE SUB_T IS T; + PAC_VAR : T; + END P; + +BEGIN + TEST ("CC3220A", "CHECK THAT A DISCRETE FORMAL TYPE DENOTES ITS " & + "ACTUAL PARAMETER, AND OPERATIONS OF THE " & + "FORMAL TYPE ARE IDENTIFIED WITH CORRESPONDING " & + "OPERATIONS OF THE ACTUAL TYPE"); + + DECLARE + OBJ_INT : INTEGER := 1; + + PACKAGE P1 IS NEW P (INTEGER); + USE P1; + + TYPE NEW_T IS NEW SUB_T; + OBJ_NEWT : NEW_T; + BEGIN + PAC_VAR := SUB_T'(1); + IF PAC_VAR /= OBJ_INT THEN + FAILED ("INCORRECT RESULTS - 1"); + END IF; + OBJ_INT := PAC_VAR + OBJ_INT; + IF OBJ_INT <= PAC_VAR THEN + FAILED ("INCORRECT RESULTS - 2"); + END IF; + PAC_VAR := PAC_VAR * OBJ_INT; + IF PAC_VAR NOT IN INTEGER THEN + FAILED ("INCORRECT RESULTS - 3"); + END IF; + IF OBJ_INT NOT IN SUB_T THEN + FAILED ("INCORRECT RESULTS - 4"); + END IF; + IF INTEGER'POS(2) /= SUB_T'POS(2) THEN + FAILED ("INCORRECT RESULTS - 5"); + END IF; + OBJ_NEWT := 1; + OBJ_NEWT := OBJ_NEWT + 1; + IF OBJ_NEWT NOT IN NEW_T THEN + FAILED ("INCORRECT RESULTS - 6"); + END IF; + IF NEW_T'SUCC(2) /= 3 THEN + FAILED ("INCORRECT RESULTS - 7"); + END IF; + END; + + DECLARE + TYPE ENUM IS (RED, YELLOW, GREEN, BLUE); + OBJ_ENU : ENUM := RED; + + PACKAGE P2 IS NEW P (ENUM); + USE P2; + + TYPE NEW_T IS NEW SUB_T; + OBJ_NEWT : NEW_T; + BEGIN + PAC_VAR := SUB_T'(RED); + IF (PAC_VAR < OBJ_ENU) OR (PAC_VAR > OBJ_ENU) THEN + FAILED ("INCORRECT RESULTS - 8"); + END IF; + IF PAC_VAR NOT IN ENUM THEN + FAILED ("INCORRECT RESULTS - 9"); + END IF; + IF OBJ_ENU NOT IN SUB_T THEN + FAILED ("INCORRECT RESULTS - 10"); + END IF; + IF ENUM'VAL(0) /= SUB_T'VAL(0) THEN + FAILED ("INCORRECT RESULTS - 11"); + END IF; + OBJ_ENU := SUB_T'SUCC(PAC_VAR); + IF SUB_T'POS(RED) /= 0 AND THEN OBJ_ENU /= BLUE THEN + FAILED ("INCORRECT RESULTS - 12"); + END IF; + OBJ_NEWT := BLUE; + OBJ_NEWT := NEW_T'PRED(OBJ_NEWT); + IF OBJ_NEWT NOT IN NEW_T THEN + FAILED ("INCORRECT RESULTS - 13"); + END IF; + IF NEW_T'WIDTH /= 6 THEN + FAILED ("INCORRECT RESULTS - 14"); + END IF; + END; + + DECLARE + OBJ_CHR : CHARACTER := 'A'; + + PACKAGE P3 IS NEW P (CHARACTER); + USE P3; + + TYPE NEW_T IS NEW SUB_T; + OBJ_NEWT : NEW_T; + ARA_NEWT : ARRAY (1 .. 5) OF NEW_T; + BEGIN + PAC_VAR := SUB_T'('A'); + IF (PAC_VAR < OBJ_CHR) OR (PAC_VAR > OBJ_CHR) THEN + FAILED ("INCORRECT RESULTS - 15"); + END IF; + IF PAC_VAR NOT IN CHARACTER THEN + FAILED ("INCORRECT RESULTS - 16"); + END IF; + IF OBJ_CHR NOT IN SUB_T THEN + FAILED ("INCORRECT RESULTS - 17"); + END IF; + IF CHARACTER'VAL(0) /= SUB_T'VAL(0) THEN + FAILED ("INCORRECT RESULTS - 18"); + END IF; + OBJ_CHR := SUB_T'SUCC(PAC_VAR); + IF SUB_T'POS('A') /= 65 AND THEN OBJ_CHR /= 'A' THEN + FAILED ("INCORRECT RESULTS - 19"); + END IF; + OBJ_NEWT := 'C'; + OBJ_NEWT := NEW_T'PRED(OBJ_NEWT); + IF OBJ_NEWT NOT IN NEW_T THEN + FAILED ("INCORRECT RESULTS - 20"); + END IF; + IF NEW_T'IMAGE('A') /= "'A'" THEN + FAILED ("INCORRECT RESULTS - 21"); + END IF; + ARA_NEWT := "HELLO"; + IF (NEW_T'('H') & NEW_T'('I')) /= "HI" THEN + FAILED ("INCORRECT RESULTS - 22"); + END IF; + END; + + RESULT; +END CC3220A; diff --git a/gcc/testsuite/ada/acats/tests/cc/cc3221a.ada b/gcc/testsuite/ada/acats/tests/cc/cc3221a.ada new file mode 100644 index 000000000..e7c7287da --- /dev/null +++ b/gcc/testsuite/ada/acats/tests/cc/cc3221a.ada @@ -0,0 +1,107 @@ +-- CC3221A.ADA + +-- Grant of Unlimited Rights +-- +-- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687, +-- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained +-- unlimited rights in the software and documentation contained herein. +-- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making +-- this public release, the Government intends to confer upon all +-- recipients unlimited rights equal to those held by the Government. +-- These rights include rights to use, duplicate, release or disclose the +-- released technical data and computer software in whole or in part, in +-- any manner and for any purpose whatsoever, and to have or permit others +-- to do so. +-- +-- DISCLAIMER +-- +-- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR +-- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED +-- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF 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 INTEGER FORMAL TYPE DENOTES ITS ACTUAL PARAMETER, AND +-- OPERATIONS OF THE FORMAL TYPE ARE IDENTIFIED WITH CORRESPONDING +-- OPERATIONS OF THE ACTUAL TYPE. + +-- TBN 10/09/86 + +WITH REPORT; USE REPORT; +PROCEDURE CC3221A IS + + GENERIC + TYPE T IS RANGE <>; + PACKAGE P IS + SUBTYPE SUB_T IS T; + PAC_VAR : T; + END P; + +BEGIN + TEST ("CC3221A", "CHECK THAT AN INTEGER FORMAL TYPE DENOTES ITS " & + "ACTUAL PARAMETER, AND OPERATIONS OF THE " & + "FORMAL TYPE ARE IDENTIFIED WITH CORRESPONDING " & + "OPERATIONS OF THE ACTUAL TYPE"); + + DECLARE + TYPE FIXED IS DELTA 0.125 RANGE 0.0 .. 10.0; + + OBJ_INT : INTEGER := 1; + OBJ_FLO : FLOAT := 1.0; + OBJ_FIX : FIXED := 1.0; + + PACKAGE P1 IS NEW P (INTEGER); + USE P1; + + TYPE NEW_T IS NEW SUB_T; + OBJ_NEWT : NEW_T; + BEGIN + PAC_VAR := SUB_T'(1); + IF PAC_VAR /= OBJ_INT THEN + FAILED ("INCORRECT RESULTS - 1"); + END IF; + OBJ_INT := PAC_VAR + OBJ_INT; + IF OBJ_INT <= PAC_VAR THEN + FAILED ("INCORRECT RESULTS - 2"); + END IF; + PAC_VAR := PAC_VAR * OBJ_INT; + IF PAC_VAR NOT IN INTEGER THEN + FAILED ("INCORRECT RESULTS - 3"); + END IF; + IF OBJ_INT NOT IN SUB_T THEN + FAILED ("INCORRECT RESULTS - 4"); + END IF; + IF INTEGER'POS(2) /= SUB_T'POS(2) THEN + FAILED ("INCORRECT RESULTS - 5"); + END IF; + PAC_VAR := 1; + OBJ_FIX := PAC_VAR * OBJ_FIX; + IF OBJ_FIX /= 1.0 THEN + FAILED ("INCORRECT RESULTS - 6"); + END IF; + OBJ_INT := 1; + OBJ_FIX := OBJ_FIX / OBJ_INT; + IF OBJ_FIX /= 1.0 THEN + FAILED ("INCORRECT RESULTS - 7"); + END IF; + OBJ_INT := OBJ_INT ** PAC_VAR; + IF OBJ_INT /= 1 THEN + FAILED ("INCORRECT RESULTS - 8"); + END IF; + OBJ_FLO := OBJ_FLO ** PAC_VAR; + IF OBJ_FLO /= 1.0 THEN + FAILED ("INCORRECT RESULTS - 9"); + END IF; + OBJ_NEWT := 1; + OBJ_NEWT := OBJ_NEWT - 1; + IF OBJ_NEWT NOT IN NEW_T THEN + FAILED ("INCORRECT RESULTS - 10"); + END IF; + IF NEW_T'SUCC(2) /= 3 THEN + FAILED ("INCORRECT RESULTS - 11"); + END IF; + END; + + RESULT; +END CC3221A; diff --git a/gcc/testsuite/ada/acats/tests/cc/cc3222a.ada b/gcc/testsuite/ada/acats/tests/cc/cc3222a.ada new file mode 100644 index 000000000..57cb19881 --- /dev/null +++ b/gcc/testsuite/ada/acats/tests/cc/cc3222a.ada @@ -0,0 +1,116 @@ +-- CC3222A.ADA + +-- Grant of Unlimited Rights +-- +-- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687, +-- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained +-- unlimited rights in the software and documentation contained herein. +-- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making +-- this public release, the Government intends to confer upon all +-- recipients unlimited rights equal to those held by the Government. +-- These rights include rights to use, duplicate, release or disclose the +-- released technical data and computer software in whole or in part, in +-- any manner and for any purpose whatsoever, and to have or permit others +-- to do so. +-- +-- DISCLAIMER +-- +-- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR +-- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED +-- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF 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 FLOATING POINT FORMAL TYPE DENOTES ITS ACTUAL +-- PARAMETER, AND OPERATIONS OF THE FORMAL TYPE ARE IDENTIFIED WITH +-- CORRESPONDING OPERATIONS OF THE ACTUAL TYPE. + +-- HISTORY: +-- TBN 10/09/86 CREATED ORIGINAL TEST. +-- PWN 01/31/95 REMOVED INCONSISTENCIES WITH ADA 9X. + +WITH REPORT; USE REPORT; +PROCEDURE CC3222A IS + + TYPE FLOAT IS DIGITS 5 RANGE 0.0 .. 10.0; + + GENERIC + TYPE T IS DIGITS <>; + PACKAGE P IS + SUBTYPE SUB_T IS T; + PAC_VAR : T; + END P; + + FUNCTION IDENT_FLO (X : FLOAT) RETURN FLOAT IS + BEGIN + IF EQUAL (3, 3) THEN + RETURN X; + ELSE + RETURN (0.0); + END IF; + END IDENT_FLO; + +BEGIN + TEST ("CC3222A", "CHECK THAT A FLOATING POINT FORMAL TYPE " & + "DENOTES ITS ACTUAL PARAMETER, AND OPERATIONS " & + "OF THE FORMAL TYPE ARE IDENTIFIED WITH " & + "CORRESPONDING OPERATIONS OF THE ACTUAL TYPE"); + + DECLARE + OBJ_INT : INTEGER := 1; + OBJ_FLO : FLOAT := 1.0; + + PACKAGE P1 IS NEW P (FLOAT); + USE P1; + + TYPE NEW_T IS NEW SUB_T; + OBJ_NEWT : NEW_T; + BEGIN + PAC_VAR := SUB_T'(1.0); + IF PAC_VAR /= OBJ_FLO THEN + FAILED ("INCORRECT RESULTS - 1"); + END IF; + OBJ_FLO := IDENT_FLO (PAC_VAR) + IDENT_FLO (OBJ_FLO); + IF OBJ_FLO <= PAC_VAR THEN + FAILED ("INCORRECT RESULTS - 2"); + END IF; + PAC_VAR := PAC_VAR * OBJ_FLO; + IF PAC_VAR NOT IN FLOAT THEN + FAILED ("INCORRECT RESULTS - 3"); + END IF; + IF OBJ_FLO NOT IN SUB_T THEN + FAILED ("INCORRECT RESULTS - 4"); + END IF; + PAC_VAR := 1.0; + OBJ_FLO := 1.0; + OBJ_FLO := PAC_VAR * OBJ_FLO; + IF OBJ_FLO /= 1.0 THEN + FAILED ("INCORRECT RESULTS - 5"); + END IF; + OBJ_FLO := 1.0; + OBJ_FLO := OBJ_FLO / OBJ_FLO; + IF OBJ_FLO /= 1.0 THEN + FAILED ("INCORRECT RESULTS - 6"); + END IF; + PAC_VAR := 1.0; + OBJ_FLO := PAC_VAR ** OBJ_INT; + IF OBJ_FLO /= 1.0 THEN + FAILED ("INCORRECT RESULTS - 7"); + END IF; + IF SUB_T'DIGITS /= 5 THEN + FAILED ("INCORRECT RESULTS - 8"); + END IF; + OBJ_NEWT := 1.0; + OBJ_NEWT := OBJ_NEWT - 1.0; + IF OBJ_NEWT NOT IN NEW_T THEN + FAILED ("INCORRECT RESULTS - 9"); + END IF; + IF NEW_T'DIGITS /= 5 THEN + FAILED ("INCORRECT RESULTS - 10"); + END IF; + END; + + RESULT; +END CC3222A; diff --git a/gcc/testsuite/ada/acats/tests/cc/cc3223a.ada b/gcc/testsuite/ada/acats/tests/cc/cc3223a.ada new file mode 100644 index 000000000..469a4963e --- /dev/null +++ b/gcc/testsuite/ada/acats/tests/cc/cc3223a.ada @@ -0,0 +1,114 @@ +-- CC3223A.ADA + +-- Grant of Unlimited Rights +-- +-- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687, +-- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained +-- unlimited rights in the software and documentation contained herein. +-- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making +-- this public release, the Government intends to confer upon all +-- recipients unlimited rights equal to those held by the Government. +-- These rights include rights to use, duplicate, release or disclose the +-- released technical data and computer software in whole or in part, in +-- any manner and for any purpose whatsoever, and to have or permit others +-- to do so. +-- +-- DISCLAIMER +-- +-- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR +-- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED +-- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF 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 FIXED POINT FORMAL TYPE DENOTES ITS ACTUAL +-- PARAMETER, AND OPERATIONS OF THE FORMAL TYPE ARE IDENTIFIED +-- WITH CORRESPONDING OPERATIONS OF THE ACTUAL TYPE. + +-- HISTORY: +-- TBN 10/09/86 CREATED ORIGINAL TEST. +-- PWN 01/31/95 REMOVED INCONSISTENCIES WITH ADA 9X. + +WITH REPORT; USE REPORT; +PROCEDURE CC3223A IS + + TYPE FIXED IS DELTA 0.125 RANGE 0.0 .. 10.0; + + GENERIC + TYPE T IS DELTA <>; + PACKAGE P IS + SUBTYPE SUB_T IS T; + PAC_VAR : T; + END P; + + FUNCTION IDENT_FIX (X : FIXED) RETURN FIXED IS + BEGIN + IF EQUAL (3, 3) THEN + RETURN X; + ELSE + RETURN (0.0); + END IF; + END IDENT_FIX; + +BEGIN + TEST ("CC3223A", "CHECK THAT A FIXED POINT FORMAL TYPE DENOTES " & + "ITS ACTUAL PARAMETER, AND OPERATIONS OF THE " & + "FORMAL TYPE ARE IDENTIFIED WITH CORRESPONDING " & + "OPERATIONS OF THE ACTUAL TYPE"); + + DECLARE + OBJ_INT : INTEGER := 1; + OBJ_FIX : FIXED := 1.0; + + PACKAGE P1 IS NEW P (FIXED); + USE P1; + + TYPE NEW_T IS NEW SUB_T; + OBJ_NEWT : NEW_T; + BEGIN + PAC_VAR := SUB_T'(1.0); + IF PAC_VAR /= OBJ_FIX THEN + FAILED ("INCORRECT RESULTS - 1"); + END IF; + OBJ_FIX := IDENT_FIX (PAC_VAR) + IDENT_FIX (OBJ_FIX); + IF OBJ_FIX <= PAC_VAR THEN + FAILED ("INCORRECT RESULTS - 2"); + END IF; + PAC_VAR := OBJ_INT * OBJ_FIX; + IF PAC_VAR NOT IN FIXED THEN + FAILED ("INCORRECT RESULTS - 3"); + END IF; + IF OBJ_FIX NOT IN SUB_T THEN + FAILED ("INCORRECT RESULTS - 4"); + END IF; + IF SUB_T'DELTA /= 0.125 THEN + FAILED ("INCORRECT RESULTS - 5"); + END IF; + OBJ_NEWT := 1.0; + OBJ_NEWT := OBJ_NEWT - 1.0; + IF OBJ_NEWT NOT IN NEW_T THEN + FAILED ("INCORRECT RESULTS - 6"); + END IF; + IF NEW_T'DELTA /= 0.125 THEN + FAILED ("INCORRECT RESULTS - 7"); + END IF; + OBJ_NEWT := NEW_T'SMALL + 1.0; + OBJ_FIX := 1.0; + OBJ_FIX := FIXED (OBJ_FIX * OBJ_FIX); + IF OBJ_FIX /= 1.0 THEN + FAILED ("INCORRECT RESULTS - 8"); + END IF; + OBJ_FIX := 1.0; + OBJ_FIX := SUB_T (OBJ_FIX / OBJ_FIX); + IF OBJ_FIX /= 1.0 THEN + FAILED ("INCORRECT RESULTS - 9"); + END IF; + IF FIXED'SMALL /= NEW_T'SMALL THEN + FAILED ("INCORRECT RESULTS - 10"); + END IF; + END; + + RESULT; +END CC3223A; diff --git a/gcc/testsuite/ada/acats/tests/cc/cc3224a.ada b/gcc/testsuite/ada/acats/tests/cc/cc3224a.ada new file mode 100644 index 000000000..5da67ea4c --- /dev/null +++ b/gcc/testsuite/ada/acats/tests/cc/cc3224a.ada @@ -0,0 +1,313 @@ +-- CC3224A.ADA + +-- Grant of Unlimited Rights +-- +-- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687, +-- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained +-- unlimited rights in the software and documentation contained herein. +-- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making +-- this public release, the Government intends to confer upon all +-- recipients unlimited rights equal to those held by the Government. +-- These rights include rights to use, duplicate, release or disclose the +-- released technical data and computer software in whole or in part, in +-- any manner and for any purpose whatsoever, and to have or permit others +-- to do so. +-- +-- DISCLAIMER +-- +-- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR +-- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED +-- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF 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 ARRAY TYPE DENOTES ITS ACTUAL +-- PARAMETER, AND THAT OPERATIONS OF THE FORMAL TYPE ARE THOSE +-- IDENTIFIED WITH THE CORRESPONDING OPERATIONS OF THE ACTUAL TYPE. + +-- HISTORY: +-- DHH 09/19/88 CREATED ORIGINAL TEST. +-- EDWARD V. BERARD, 14 AUGUST 1990 ADDED CHECKS FOR MULTI- +-- DIMENSIONAL ARRAYS +-- PWN 11/30/94 REMOVED 'BASE USE ILLEGAL IN ADA 9X. + +WITH REPORT ; + +PROCEDURE CC3224A IS + + SUBTYPE INT IS INTEGER RANGE 1 .. 3; + TYPE ARR IS ARRAY(1 .. 3) OF INTEGER; + TYPE B_ARR IS ARRAY(1 .. 3) OF BOOLEAN; + + Q : ARR; + R : B_ARR; + + GENERIC + TYPE T IS ARRAY(INT) OF INTEGER; + PACKAGE P IS + SUBTYPE SUB_T IS T; + X : SUB_T := (1, 2, 3); + END P; + + GENERIC + TYPE T IS ARRAY(INT) OF BOOLEAN; + PACKAGE BOOL IS + SUBTYPE SUB_T IS T; + END BOOL; + + SHORT_START : CONSTANT := -100 ; + SHORT_END : CONSTANT := 100 ; + TYPE SHORT_RANGE IS RANGE SHORT_START .. SHORT_END ; + + SUBTYPE REALLY_SHORT IS SHORT_RANGE RANGE -9 .. 0 ; + + TYPE MONTH_TYPE IS (JAN, FEB, MAR, APR, MAY, JUN, JUL, AUG, + SEP, OCT, NOV, DEC) ; + + SUBTYPE FIRST_HALF IS MONTH_TYPE RANGE JAN .. JUN ; + + TYPE DAY_TYPE IS RANGE 1 .. 31 ; + TYPE YEAR_TYPE IS RANGE 1904 .. 2050 ; + TYPE DATE IS RECORD + MONTH : MONTH_TYPE ; + DAY : DAY_TYPE ; + YEAR : YEAR_TYPE ; + END RECORD ; + + TODAY : DATE := (MONTH => AUG, + DAY => 8, + YEAR => 1990) ; + + FIRST_DATE : DATE := (DAY => 6, + MONTH => JUN, + YEAR => 1967) ; + + WALL_DATE : DATE := (MONTH => NOV, + DAY => 9, + YEAR => 1989) ; + + SUBTYPE FIRST_FIVE IS CHARACTER RANGE 'A' .. 'E' ; + + TYPE THREE_DIMENSIONAL IS ARRAY (REALLY_SHORT, + FIRST_HALF, + FIRST_FIVE) OF DATE ; + + TD_ARRAY : THREE_DIMENSIONAL ; + SECOND_TD_ARRAY : THREE_DIMENSIONAL ; + + GENERIC + + TYPE CUBE IS ARRAY (REALLY_SHORT, + FIRST_HALF, + FIRST_FIVE) OF DATE ; + + PACKAGE TD_ARRAY_PACKAGE IS + + SUBTYPE SUB_CUBE IS CUBE ; + TEST_3D_ARRAY : SUB_CUBE := (THREE_DIMENSIONAL'RANGE => + (THREE_DIMENSIONAL'RANGE (2) => + (THREE_DIMENSIONAL'RANGE (3) => + TODAY))) ; + + END TD_ARRAY_PACKAGE ; + + +BEGIN -- CC3224A + + REPORT.TEST ("CC3224A", "CHECK THAT A FORMAL ARRAY TYPE DENOTES " & + "ITS ACTUAL PARAMETER, AND THAT OPERATIONS OF " & + "THE FORMAL TYPE ARE THOSE IDENTIFIED WITH THE " & + "CORRESPONDING OPERATIONS OF THE ACTUAL TYPE"); + + ONE_DIMENSIONAL: + + DECLARE + + PACKAGE P1 IS NEW P (ARR); + + TYPE NEW_T IS NEW P1.SUB_T; + OBJ_NEWT : NEW_T; + + BEGIN -- ONE_DIMENSIONAL + + IF NEW_T'FIRST /= ARR'FIRST THEN + REPORT.FAILED("'FIRST ATTRIBUTE REPORT.FAILED"); + END IF; + + IF NEW_T'LAST /= ARR'LAST THEN + REPORT.FAILED("'LAST ATTRIBUTE REPORT.FAILED"); + END IF; + + IF NEW_T'FIRST(1) /= ARR'FIRST(1) THEN + REPORT.FAILED("'FIRST(N) ATTRIBUTE REPORT.FAILED"); + END IF; + + IF NOT (NEW_T'LAST(1) = ARR'LAST(1)) THEN + REPORT.FAILED("'LAST(N) ATTRIBUTE REPORT.FAILED"); + END IF; + + IF 2 NOT IN NEW_T'RANGE THEN + REPORT.FAILED("'RANGE ATTRIBUTE REPORT.FAILED"); + END IF; + + IF 3 NOT IN NEW_T'RANGE(1) THEN + REPORT.FAILED("'RANGE(N) ATTRIBUTE REPORT.FAILED"); + END IF; + + IF NEW_T'LENGTH /= ARR'LENGTH THEN + REPORT.FAILED("'LENGTH ATTRIBUTE REPORT.FAILED"); + END IF; + + IF NEW_T'LENGTH(1) /= ARR'LENGTH(1) THEN + REPORT.FAILED("'LENGTH(N) ATTRIBUTE REPORT.FAILED"); + END IF; + + OBJ_NEWT := (1, 2, 3); + IF REPORT.IDENT_INT(3) /= OBJ_NEWT(3) THEN + REPORT.FAILED("ASSIGNMENT REPORT.FAILED"); + END IF; + + IF NEW_T'(1, 2, 3) NOT IN NEW_T THEN + REPORT.FAILED("QUALIFIED EXPRESSION REPORT.FAILED"); + END IF; + + Q := (1, 2, 3); + IF NEW_T(Q) /= OBJ_NEWT THEN + REPORT.FAILED("EXPLICIT CONVERSION REPORT.FAILED"); + END IF; + + IF Q(1) /= OBJ_NEWT(1) THEN + REPORT.FAILED("INDEXING REPORT.FAILED"); + END IF; + + IF (1, 2) /= OBJ_NEWT(1 .. 2) THEN + REPORT.FAILED("SLICE REPORT.FAILED"); + END IF; + + IF (1, 2) & OBJ_NEWT(3) /= NEW_T(Q)THEN + REPORT.FAILED("CATENATION REPORT.FAILED"); + END IF; + + IF NOT (P1.X IN ARR) THEN + REPORT.FAILED ("FORMAL DOES NOT DENOTE ACTUAL"); + END IF; + + END ONE_DIMENSIONAL ; + + BOOLEAN_ONE_DIMENSIONAL: + + DECLARE + + PACKAGE B1 IS NEW BOOL (B_ARR); + + TYPE NEW_T IS NEW B1.SUB_T; + OBJ_NEWT : NEW_T; + + BEGIN -- BOOLEAN_ONE_DIMENSIONAL + + OBJ_NEWT := (TRUE, TRUE, TRUE); + R := (TRUE, TRUE, TRUE); + + IF (NEW_T'((TRUE, TRUE, TRUE)) XOR OBJ_NEWT) /= + NEW_T'((FALSE, FALSE, FALSE)) THEN + REPORT.FAILED("XOR REPORT.FAILED - BOOLEAN") ; + END IF; + + IF (NEW_T'((FALSE, FALSE, TRUE)) AND OBJ_NEWT) /= + NEW_T'((FALSE, FALSE, TRUE)) THEN + REPORT.FAILED("AND REPORT.FAILED - BOOLEAN") ; + END IF; + + IF (NEW_T'((FALSE, FALSE, FALSE)) OR OBJ_NEWT) /= + NEW_T'((TRUE, TRUE, TRUE)) THEN + REPORT.FAILED("OR REPORT.FAILED - BOOLEAN") ; + END IF ; + + END BOOLEAN_ONE_DIMENSIONAL ; + + THREE_DIMENSIONAL_TEST: + + DECLARE + + PACKAGE TD IS NEW TD_ARRAY_PACKAGE (CUBE => THREE_DIMENSIONAL) ; + + TYPE NEW_CUBE IS NEW TD.SUB_CUBE ; + NEW_CUBE_OBJECT : NEW_CUBE ; + + BEGIN -- THREE_DIMENSIONAL_TEST + + IF (NEW_CUBE'FIRST /= THREE_DIMENSIONAL'FIRST) OR + (NEW_CUBE'FIRST (1) /= THREE_DIMENSIONAL'FIRST) OR + (NEW_CUBE'FIRST (2) /= THREE_DIMENSIONAL'FIRST (2)) OR + (NEW_CUBE'FIRST (3) /= THREE_DIMENSIONAL'FIRST (3)) THEN + REPORT.FAILED ("PROBLEMS WITH 'FIRST FOR MULTI-" & + "DIMENSIONAL ARRAYS.") ; + END IF ; + + IF (NEW_CUBE'LAST /= THREE_DIMENSIONAL'LAST) OR + (NEW_CUBE'LAST (1) /= THREE_DIMENSIONAL'LAST) OR + (NEW_CUBE'LAST (2) /= THREE_DIMENSIONAL'LAST (2)) OR + (NEW_CUBE'LAST (3) /= THREE_DIMENSIONAL'LAST (3)) THEN + REPORT.FAILED ("PROBLEMS WITH 'LAST FOR MULTI-" & + "DIMENSIONAL ARRAYS.") ; + END IF ; + + IF (-5 NOT IN NEW_CUBE'RANGE) OR + (-3 NOT IN NEW_CUBE'RANGE (1)) OR + (FEB NOT IN NEW_CUBE'RANGE (2)) OR + ('C' NOT IN NEW_CUBE'RANGE (3)) THEN + REPORT.FAILED ("PROBLEMS WITH 'RANGE FOR MULTI-" & + "DIMENSIONAL ARRAYS.") ; + END IF ; + + IF (NEW_CUBE'LENGTH /= THREE_DIMENSIONAL'LENGTH) OR + (NEW_CUBE'LENGTH (1) /= THREE_DIMENSIONAL'LENGTH) OR + (NEW_CUBE'LENGTH (2) /= THREE_DIMENSIONAL'LENGTH (2)) OR + (NEW_CUBE'LENGTH (3) /= THREE_DIMENSIONAL'LENGTH (3)) THEN + REPORT.FAILED ("PROBLEMS WITH 'LENGTH FOR MULTI-" & + "DIMENSIONAL ARRAYS.") ; + END IF ; + + NEW_CUBE_OBJECT := (NEW_CUBE'RANGE => + (NEW_CUBE'RANGE (2) => + (NEW_CUBE'RANGE (3) => + FIRST_DATE))) ; + IF FIRST_DATE /= NEW_CUBE_OBJECT (-3, MAR, 'D') THEN + REPORT.FAILED ("ASSIGNMENT FOR MULTI-DIMENSIONAL " & + "ARRAYS FAILED.") ; + END IF ; + + IF NEW_CUBE'(NEW_CUBE'RANGE => + (NEW_CUBE'RANGE (2) => + (NEW_CUBE'RANGE (3) => + WALL_DATE))) NOT IN NEW_CUBE THEN + REPORT.FAILED ("QUALIFIED EXPRESSION FOR MULTI-" & + "DIMENSIONAL ARRAYS FAILED.") ; + END IF ; + + SECOND_TD_ARRAY := (NEW_CUBE'RANGE => + (NEW_CUBE'RANGE (2) => + (NEW_CUBE'RANGE (3) => + FIRST_DATE))) ; + IF NEW_CUBE (SECOND_TD_ARRAY) /= NEW_CUBE_OBJECT THEN + REPORT.FAILED ("EXPLICIT CONVERSION FOR MULTI-" & + "DIMENSIONAL ARRAYS FAILED.") ; + END IF ; + + IF SECOND_TD_ARRAY (-2, FEB, 'B') + /= NEW_CUBE_OBJECT (-2, FEB, 'B') THEN + REPORT.FAILED ("INDEXING FOR MULTI-" & + "DIMENSIONAL ARRAYS FAILED.") ; + END IF ; + + IF NOT (TD.TEST_3D_ARRAY IN THREE_DIMENSIONAL) THEN + REPORT.FAILED ("FORMAL MULTI-DIMENSIONAL ARRAY " & + "DOES NOT DENOTE ACTUAL.") ; + END IF ; + + END THREE_DIMENSIONAL_TEST ; + + REPORT.RESULT ; + +END CC3224A ; diff --git a/gcc/testsuite/ada/acats/tests/cc/cc3225a.ada b/gcc/testsuite/ada/acats/tests/cc/cc3225a.ada new file mode 100644 index 000000000..478664f43 --- /dev/null +++ b/gcc/testsuite/ada/acats/tests/cc/cc3225a.ada @@ -0,0 +1,183 @@ +-- CC3225A.ADA + +-- Grant of Unlimited Rights +-- +-- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687, +-- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained +-- unlimited rights in the software and documentation contained herein. +-- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making +-- this public release, the Government intends to confer upon all +-- recipients unlimited rights equal to those held by the Government. +-- These rights include rights to use, duplicate, release or disclose the +-- released technical data and computer software in whole or in part, in +-- any manner and for any purpose whatsoever, and to have or permit others +-- to do so. +-- +-- DISCLAIMER +-- +-- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR +-- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED +-- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF 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 ACCESS TYPE DENOTES ITS ACTUAL +-- PARAMETER, AND THAT OPERATIONS OF THE FORMAL TYPE ARE THOSE +-- IDENTIFIED WITH THE CORRESPONDING OPERATIONS OF THE ACTUAL TYPE. + +-- HISTORY: +-- DHH 10/21/88 CREATED ORIGINAL TEST. +-- PWN 02/02/95 REMOVED INCONSISTENCIES WITH ADA 9X. + +WITH REPORT; USE REPORT; +PROCEDURE CC3225A IS + + GENERIC + TYPE NODE IS PRIVATE; + TYPE T IS ACCESS NODE; + PACKAGE P IS + SUBTYPE SUB_T IS T; + PAC_VAR : SUB_T; + END P; + +BEGIN + TEST ("CC3225A", "CHECK THAT A FORMAL ACCESS TYPE DENOTES ITS " & + "ACTUAL PARAMETER, AND THAT OPERATIONS OF THE " & + "FORMAL TYPE ARE THOSE IDENTIFIED WITH THE " & + "CORRESPONDING OPERATIONS OF THE ACTUAL TYPE"); + + DECLARE + SUBTYPE INT IS INTEGER RANGE 1 .. 3; + TYPE ARR IS ARRAY(1 .. 3) OF INTEGER; + TYPE ACC_ARR IS ACCESS ARR; + + Q : ACC_ARR := NEW ARR; + + PACKAGE P1 IS NEW P (ARR, ACC_ARR); + USE P1; + + BEGIN + PAC_VAR := NEW ARR'(1, 2, 3); + IF PAC_VAR'FIRST /= Q'FIRST THEN + FAILED("'FIRST ATTRIBUTE FAILED"); + END IF; + IF PAC_VAR'LAST /= Q'LAST THEN + FAILED("'LAST ATTRIBUTE FAILED"); + END IF; + IF PAC_VAR'FIRST(1) /= Q'FIRST(1) THEN + FAILED("'FIRST(N) ATTRIBUTE FAILED"); + END IF; + IF NOT (PAC_VAR'LAST(1) = Q'LAST(1)) THEN + FAILED("'LAST(N) ATTRIBUTE FAILED"); + END IF; + IF 2 NOT IN PAC_VAR'RANGE THEN + FAILED("'RANGE ATTRIBUTE FAILED"); + END IF; + IF 3 NOT IN PAC_VAR'RANGE(1) THEN + FAILED("'RANGE(N) ATTRIBUTE FAILED"); + END IF; + IF PAC_VAR'LENGTH /= Q'LENGTH THEN + FAILED("'LENGTH ATTRIBUTE FAILED"); + END IF; + IF PAC_VAR'LENGTH(1) /= Q'LENGTH(1) THEN + FAILED("'LENGTH(N) ATTRIBUTE FAILED"); + END IF; + + PAC_VAR.ALL := (1, 2, 3); + IF IDENT_INT(3) /= PAC_VAR(3) THEN + FAILED("ASSIGNMENT FAILED"); + END IF; + + IF SUB_T'(PAC_VAR) NOT IN SUB_T THEN + FAILED("QUALIFIED EXPRESSION FAILED"); + END IF; + + Q.ALL := PAC_VAR.ALL; + IF SUB_T(Q) = PAC_VAR THEN + FAILED("EXPLICIT CONVERSION FAILED"); + END IF; + IF Q(1) /= PAC_VAR(1) THEN + FAILED("INDEXING FAILED"); + END IF; + IF (1, 2) /= PAC_VAR(1 .. 2) THEN + FAILED("SLICE FAILED"); + END IF; + IF (1, 2) & PAC_VAR(3) /= PAC_VAR.ALL THEN + FAILED("CATENATION FAILED"); + END IF; + END; + + DECLARE + TASK TYPE TSK IS + ENTRY ONE; + END TSK; + + GENERIC + TYPE T IS ACCESS TSK; + PACKAGE P IS + SUBTYPE SUB_T IS T; + PAC_VAR : SUB_T; + END P; + + TYPE ACC_TSK IS ACCESS TSK; + + PACKAGE P1 IS NEW P(ACC_TSK); + USE P1; + + GLOBAL : INTEGER := 5; + + TASK BODY TSK IS + BEGIN + ACCEPT ONE DO + GLOBAL := 1; + END ONE; + END; + BEGIN + PAC_VAR := NEW TSK; + PAC_VAR.ONE; + IF GLOBAL /= 1 THEN + FAILED("TASK ENTRY SELECTION FAILED"); + END IF; + END; + + DECLARE + TYPE REC IS + RECORD + I : INTEGER; + B : BOOLEAN; + END RECORD; + + TYPE ACC_REC IS ACCESS REC; + + PACKAGE P1 IS NEW P (REC, ACC_REC); + USE P1; + + BEGIN + PAC_VAR := NEW REC'(4, (PAC_VAR IN ACC_REC)); + IF PAC_VAR.I /= IDENT_INT(4) AND NOT PAC_VAR.B THEN + FAILED("RECORD COMPONENT SELECTION FAILED"); + END IF; + END; + + DECLARE + TYPE REC(B : BOOLEAN := FALSE) IS + RECORD + NULL; + END RECORD; + + TYPE ACC_REC IS ACCESS REC; + + PACKAGE P1 IS NEW P (REC, ACC_REC); + USE P1; + + BEGIN + PAC_VAR := NEW REC'(B => PAC_VAR IN ACC_REC); + IF NOT PAC_VAR.B THEN + FAILED("DISCRIMINANT SELECTION FAILED"); + END IF; + END; + + RESULT; +END CC3225A; diff --git a/gcc/testsuite/ada/acats/tests/cc/cc3230a.ada b/gcc/testsuite/ada/acats/tests/cc/cc3230a.ada new file mode 100644 index 000000000..7f40896a9 --- /dev/null +++ b/gcc/testsuite/ada/acats/tests/cc/cc3230a.ada @@ -0,0 +1,133 @@ +-- CC3230A.ADA + +-- Grant of Unlimited Rights +-- +-- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687, +-- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained +-- unlimited rights in the software and documentation contained herein. +-- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making +-- this public release, the Government intends to confer upon all +-- recipients unlimited rights equal to those held by the Government. +-- These rights include rights to use, duplicate, release or disclose the +-- released technical data and computer software in whole or in part, in +-- any manner and for any purpose whatsoever, and to have or permit others +-- to do so. +-- +-- DISCLAIMER +-- +-- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR +-- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED +-- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF 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 PRIVATE OR LIMITED PRIVATE FORMAL TYPE DENOTES ITS +-- ACTUAL PARAMETER AN ENUMERATION TYPE, AND OPERATIONS OF THE +-- FORMAL TYPE ARE IDENTIFIED WITH CORRESPONDING OPERATIONS OF THE +-- ACTUAL TYPE. + +-- HISTORY: +-- TBN 09/14/88 CREATED ORIGINAL TEST. + +WITH REPORT; USE REPORT; +PROCEDURE CC3230A IS + + GENERIC + TYPE T IS PRIVATE; + PACKAGE P IS + SUBTYPE SUB_T IS T; + PAC_VAR : T; + END P; + + GENERIC + TYPE T IS LIMITED PRIVATE; + PACKAGE LP IS + SUBTYPE SUB_T IS T; + PAC_VAR : T; + END LP; + +BEGIN + TEST ("CC3230A", "CHECK THAT A PRIVATE OR LIMITED PRIVATE " & + "FORMAL TYPE DENOTES ITS ACTUAL PARAMETER AN " & + "ENUMERATION TYPE, AND OPERATIONS OF THE " & + "FORMAL TYPE ARE IDENTIFIED WITH CORRESPONDING " & + "OPERATIONS OF THE ACTUAL TYPE"); + + DECLARE + TYPE ENUM IS (RED, YELLOW, GREEN, BLUE); + OBJ_ENU : ENUM := RED; + + PACKAGE P2 IS NEW P (ENUM); + USE P2; + + TYPE NEW_T IS NEW SUB_T; + OBJ_NEWT : NEW_T; + BEGIN + PAC_VAR := SUB_T'(RED); + IF (PAC_VAR < OBJ_ENU) OR (PAC_VAR > OBJ_ENU) THEN + FAILED ("INCORRECT RESULTS - 1"); + END IF; + IF PAC_VAR NOT IN ENUM THEN + FAILED ("INCORRECT RESULTS - 2"); + END IF; + IF OBJ_ENU NOT IN SUB_T THEN + FAILED ("INCORRECT RESULTS - 3"); + END IF; + IF ENUM'VAL(0) /= SUB_T'VAL(0) THEN + FAILED ("INCORRECT RESULTS - 4"); + END IF; + OBJ_ENU := SUB_T'SUCC(PAC_VAR); + IF SUB_T'POS(RED) /= 0 AND THEN OBJ_ENU /= BLUE THEN + FAILED ("INCORRECT RESULTS - 5"); + END IF; + OBJ_NEWT := BLUE; + OBJ_NEWT := NEW_T'PRED(OBJ_NEWT); + IF OBJ_NEWT NOT IN NEW_T THEN + FAILED ("INCORRECT RESULTS - 6"); + END IF; + IF NEW_T'WIDTH /= 6 THEN + FAILED ("INCORRECT RESULTS - 7"); + END IF; + END; + + DECLARE + TYPE ENUM IS (RED, YELLOW, GREEN, BLUE); + OBJ_ENU : ENUM := RED; + + PACKAGE P2 IS NEW LP (ENUM); + USE P2; + + TYPE NEW_T IS NEW SUB_T; + OBJ_NEWT : NEW_T; + BEGIN + PAC_VAR := SUB_T'(RED); + IF (PAC_VAR < OBJ_ENU) OR (PAC_VAR > OBJ_ENU) THEN + FAILED ("INCORRECT RESULTS - 8"); + END IF; + IF PAC_VAR NOT IN ENUM THEN + FAILED ("INCORRECT RESULTS - 9"); + END IF; + IF OBJ_ENU NOT IN SUB_T THEN + FAILED ("INCORRECT RESULTS - 10"); + END IF; + IF ENUM'VAL(0) /= SUB_T'VAL(0) THEN + FAILED ("INCORRECT RESULTS - 11"); + END IF; + OBJ_ENU := SUB_T'SUCC(PAC_VAR); + IF SUB_T'POS(RED) /= 0 AND THEN OBJ_ENU /= BLUE THEN + FAILED ("INCORRECT RESULTS - 12"); + END IF; + OBJ_NEWT := BLUE; + OBJ_NEWT := NEW_T'PRED(OBJ_NEWT); + IF OBJ_NEWT NOT IN NEW_T THEN + FAILED ("INCORRECT RESULTS - 13"); + END IF; + IF NEW_T'WIDTH /= 6 THEN + FAILED ("INCORRECT RESULTS - 14"); + END IF; + END; + + RESULT; +END CC3230A; diff --git a/gcc/testsuite/ada/acats/tests/cc/cc3231a.ada b/gcc/testsuite/ada/acats/tests/cc/cc3231a.ada new file mode 100644 index 000000000..a36bccfc8 --- /dev/null +++ b/gcc/testsuite/ada/acats/tests/cc/cc3231a.ada @@ -0,0 +1,177 @@ +-- CC3231A.ADA + +-- Grant of Unlimited Rights +-- +-- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687, +-- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained +-- unlimited rights in the software and documentation contained herein. +-- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making +-- this public release, the Government intends to confer upon all +-- recipients unlimited rights equal to those held by the Government. +-- These rights include rights to use, duplicate, release or disclose the +-- released technical data and computer software in whole or in part, in +-- any manner and for any purpose whatsoever, and to have or permit others +-- to do so. +-- +-- DISCLAIMER +-- +-- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR +-- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED +-- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF 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 PRIVATE OR LIMITED PRIVATE FORMAL TYPE DENOTES ITS +-- ACTUAL PARAMETER AN INTEGER TYPE, AND OPERATIONS OF THE FORMAL +-- TYPE ARE IDENTIFIED WITH CORRESPONDING OPERATIONS OF THE ACTUAL +-- TYPE. + +-- HISTORY: +-- TBN 09/14/88 CREATED ORIGINAL TEST. + +WITH REPORT; USE REPORT; +PROCEDURE CC3231A IS + + GENERIC + TYPE T IS PRIVATE; + PACKAGE P IS + SUBTYPE SUB_T IS T; + PAC_VAR : T; + END P; + + GENERIC + TYPE T IS LIMITED PRIVATE; + PACKAGE LP IS + SUBTYPE SUB_T IS T; + PAC_VAR : T; + END LP; + +BEGIN + TEST ("CC3231A", "CHECK THAT A PRIVATE OR LIMITED PRIVATE " & + "FORMAL TYPE DENOTES ITS ACTUAL PARAMETER AN " & + "INTEGER TYPE, AND OPERATIONS OF THE " & + "FORMAL TYPE ARE IDENTIFIED WITH CORRESPONDING " & + "OPERATIONS OF THE ACTUAL TYPE"); + + DECLARE -- PRIVATE TYPE. + TYPE FIXED IS DELTA 0.125 RANGE 0.0 .. 10.0; + + OBJ_INT : INTEGER := 1; + OBJ_FLO : FLOAT := 1.0; + OBJ_FIX : FIXED := 1.0; + + PACKAGE P1 IS NEW P (INTEGER); + USE P1; + + TYPE NEW_T IS NEW SUB_T; + OBJ_NEWT : NEW_T; + BEGIN + PAC_VAR := SUB_T'(1); + IF PAC_VAR /= OBJ_INT THEN + FAILED ("INCORRECT RESULTS - 1"); + END IF; + OBJ_INT := PAC_VAR + OBJ_INT; + IF OBJ_INT <= PAC_VAR THEN + FAILED ("INCORRECT RESULTS - 2"); + END IF; + PAC_VAR := PAC_VAR * OBJ_INT; + IF PAC_VAR NOT IN INTEGER THEN + FAILED ("INCORRECT RESULTS - 3"); + END IF; + IF OBJ_INT NOT IN SUB_T THEN + FAILED ("INCORRECT RESULTS - 4"); + END IF; + IF INTEGER'POS(2) /= SUB_T'POS(2) THEN + FAILED ("INCORRECT RESULTS - 5"); + END IF; + PAC_VAR := 1; + OBJ_FIX := PAC_VAR * OBJ_FIX; + IF OBJ_FIX /= 1.0 THEN + FAILED ("INCORRECT RESULTS - 6"); + END IF; + OBJ_INT := 1; + OBJ_FIX := OBJ_FIX / OBJ_INT; + IF OBJ_FIX /= 1.0 THEN + FAILED ("INCORRECT RESULTS - 7"); + END IF; + OBJ_INT := OBJ_INT ** PAC_VAR; + IF OBJ_INT /= 1 THEN + FAILED ("INCORRECT RESULTS - 8"); + END IF; + OBJ_FLO := OBJ_FLO ** PAC_VAR; + IF OBJ_FLO /= 1.0 THEN + FAILED ("INCORRECT RESULTS - 9"); + END IF; + OBJ_NEWT := 1; + OBJ_NEWT := OBJ_NEWT - 1; + IF OBJ_NEWT NOT IN NEW_T THEN + FAILED ("INCORRECT RESULTS - 10"); + END IF; + IF NEW_T'SUCC(2) /= 3 THEN + FAILED ("INCORRECT RESULTS - 11"); + END IF; + END; + + DECLARE -- LIMITED PRIVATE TYPE. + TYPE FIXED IS DELTA 0.125 RANGE 0.0 .. 10.0; + + OBJ_INT : INTEGER := 1; + OBJ_FLO : FLOAT := 1.0; + OBJ_FIX : FIXED := 1.0; + + PACKAGE P1 IS NEW LP (INTEGER); + USE P1; + + TYPE NEW_T IS NEW SUB_T; + OBJ_NEWT : NEW_T; + BEGIN + PAC_VAR := SUB_T'(1); + IF PAC_VAR /= OBJ_INT THEN + FAILED ("INCORRECT RESULTS - 12"); + END IF; + OBJ_INT := PAC_VAR + OBJ_INT; + IF OBJ_INT <= PAC_VAR THEN + FAILED ("INCORRECT RESULTS - 13"); + END IF; + PAC_VAR := PAC_VAR * OBJ_INT; + IF PAC_VAR NOT IN INTEGER THEN + FAILED ("INCORRECT RESULTS - 14"); + END IF; + IF OBJ_INT NOT IN SUB_T THEN + FAILED ("INCORRECT RESULTS - 15"); + END IF; + IF INTEGER'POS(2) /= SUB_T'POS(2) THEN + FAILED ("INCORRECT RESULTS - 16"); + END IF; + PAC_VAR := 1; + OBJ_FIX := PAC_VAR * OBJ_FIX; + IF OBJ_FIX /= 1.0 THEN + FAILED ("INCORRECT RESULTS - 17"); + END IF; + OBJ_INT := 1; + OBJ_FIX := OBJ_FIX / OBJ_INT; + IF OBJ_FIX /= 1.0 THEN + FAILED ("INCORRECT RESULTS - 18"); + END IF; + OBJ_INT := OBJ_INT ** PAC_VAR; + IF OBJ_INT /= 1 THEN + FAILED ("INCORRECT RESULTS - 19"); + END IF; + OBJ_FLO := OBJ_FLO ** PAC_VAR; + IF OBJ_FLO /= 1.0 THEN + FAILED ("INCORRECT RESULTS - 20"); + END IF; + OBJ_NEWT := 1; + OBJ_NEWT := OBJ_NEWT - 1; + IF OBJ_NEWT NOT IN NEW_T THEN + FAILED ("INCORRECT RESULTS - 21"); + END IF; + IF NEW_T'SUCC(2) /= 3 THEN + FAILED ("INCORRECT RESULTS - 22"); + END IF; + END; + + RESULT; +END CC3231A; diff --git a/gcc/testsuite/ada/acats/tests/cc/cc3232a.ada b/gcc/testsuite/ada/acats/tests/cc/cc3232a.ada new file mode 100644 index 000000000..9b4b5445d --- /dev/null +++ b/gcc/testsuite/ada/acats/tests/cc/cc3232a.ada @@ -0,0 +1,179 @@ +-- CC3232A.ADA + +-- Grant of Unlimited Rights +-- +-- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687, +-- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained +-- unlimited rights in the software and documentation contained herein. +-- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making +-- this public release, the Government intends to confer upon all +-- recipients unlimited rights equal to those held by the Government. +-- These rights include rights to use, duplicate, release or disclose the +-- released technical data and computer software in whole or in part, in +-- any manner and for any purpose whatsoever, and to have or permit others +-- to do so. +-- +-- DISCLAIMER +-- +-- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR +-- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED +-- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF 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 PRIVATE OR LIMITED PRIVATE FORMAL TYPE DENOTES ITS +-- ACTUAL PARAMETER A FLOATING POINT TYPE, AND OPERATIONS OF THE +-- FORMAL TYPE ARE IDENTIFIED WITH CORRESPONDING OPERATIONS OF THE +-- ACTUAL TYPE. + +-- HISTORY: +-- TBN 09/15/88 CREATED ORIGINAL TEST. +-- PWN 01/31/95 REMOVED INCONSISTENCIES WITH ADA 9X. + +WITH REPORT; USE REPORT; +PROCEDURE CC3232A IS + + TYPE FLOAT IS DIGITS 5 RANGE 0.0 .. 10.0; + + GENERIC + TYPE T IS PRIVATE; + PACKAGE P IS + SUBTYPE SUB_T IS T; + PAC_VAR : T; + END P; + + GENERIC + TYPE T IS LIMITED PRIVATE; + PACKAGE LP IS + SUBTYPE SUB_T IS T; + PAC_VAR : T; + END LP; + + FUNCTION IDENT_FLO (X : FLOAT) RETURN FLOAT IS + BEGIN + IF EQUAL (3, 3) THEN + RETURN X; + ELSE + RETURN (0.0); + END IF; + END IDENT_FLO; + +BEGIN + TEST ("CC3232A", "CHECK THAT A PRIVATE OR LIMITED PRIVATE " & + "FORMAL TYPE DENOTES ITS ACTUAL PARAMETER A " & + "FLOATING POINT TYPE, AND OPERATIONS OF THE " & + "FORMAL TYPE ARE IDENTIFIED WITH CORRESPONDING " & + "OPERATIONS OF THE ACTUAL TYPE"); + + DECLARE -- PRIVATE TYPE. + OBJ_INT : INTEGER := 1; + OBJ_FLO : FLOAT := 1.0; + + PACKAGE P1 IS NEW P (FLOAT); + USE P1; + + TYPE NEW_T IS NEW SUB_T; + OBJ_NEWT : NEW_T; + BEGIN + PAC_VAR := SUB_T'(1.0); + IF PAC_VAR /= OBJ_FLO THEN + FAILED ("INCORRECT RESULTS - 1"); + END IF; + OBJ_FLO := IDENT_FLO (PAC_VAR) + IDENT_FLO (OBJ_FLO); + IF OBJ_FLO <= PAC_VAR THEN + FAILED ("INCORRECT RESULTS - 2"); + END IF; + PAC_VAR := PAC_VAR * OBJ_FLO; + IF PAC_VAR NOT IN FLOAT THEN + FAILED ("INCORRECT RESULTS - 3"); + END IF; + IF OBJ_FLO NOT IN SUB_T THEN + FAILED ("INCORRECT RESULTS - 4"); + END IF; + PAC_VAR := 1.0; + OBJ_FLO := 1.0; + OBJ_FLO := PAC_VAR * OBJ_FLO; + IF OBJ_FLO /= 1.0 THEN + FAILED ("INCORRECT RESULTS - 5"); + END IF; + OBJ_FLO := 1.0; + OBJ_FLO := OBJ_FLO / OBJ_FLO; + IF OBJ_FLO /= 1.0 THEN + FAILED ("INCORRECT RESULTS - 6"); + END IF; + PAC_VAR := 1.0; + OBJ_FLO := PAC_VAR ** OBJ_INT; + IF OBJ_FLO /= 1.0 THEN + FAILED ("INCORRECT RESULTS - 7"); + END IF; + IF SUB_T'DIGITS /= 5 THEN + FAILED ("INCORRECT RESULTS - 8"); + END IF; + OBJ_NEWT := 1.0; + OBJ_NEWT := OBJ_NEWT - 1.0; + IF OBJ_NEWT NOT IN NEW_T THEN + FAILED ("INCORRECT RESULTS - 9"); + END IF; + IF NEW_T'DIGITS /= 5 THEN + FAILED ("INCORRECT RESULTS - 10"); + END IF; + END; + + DECLARE -- LIMITED PRIVATE TYPE. + OBJ_INT : INTEGER := 1; + OBJ_FLO : FLOAT := 1.0; + + PACKAGE P1 IS NEW LP (FLOAT); + USE P1; + + TYPE NEW_T IS NEW SUB_T; + OBJ_NEWT : NEW_T; + BEGIN + PAC_VAR := SUB_T'(1.0); + IF PAC_VAR /= OBJ_FLO THEN + FAILED ("INCORRECT RESULTS - 1"); + END IF; + OBJ_FLO := IDENT_FLO (PAC_VAR) + IDENT_FLO (OBJ_FLO); + IF OBJ_FLO <= PAC_VAR THEN + FAILED ("INCORRECT RESULTS - 2"); + END IF; + PAC_VAR := PAC_VAR * OBJ_FLO; + IF PAC_VAR NOT IN FLOAT THEN + FAILED ("INCORRECT RESULTS - 3"); + END IF; + IF OBJ_FLO NOT IN SUB_T THEN + FAILED ("INCORRECT RESULTS - 4"); + END IF; + PAC_VAR := 1.0; + OBJ_FLO := 1.0; + OBJ_FLO := PAC_VAR * OBJ_FLO; + IF OBJ_FLO /= 1.0 THEN + FAILED ("INCORRECT RESULTS - 5"); + END IF; + OBJ_FLO := 1.0; + OBJ_FLO := OBJ_FLO / OBJ_FLO; + IF OBJ_FLO /= 1.0 THEN + FAILED ("INCORRECT RESULTS - 6"); + END IF; + PAC_VAR := 1.0; + OBJ_FLO := PAC_VAR ** OBJ_INT; + IF OBJ_FLO /= 1.0 THEN + FAILED ("INCORRECT RESULTS - 7"); + END IF; + IF SUB_T'DIGITS /= 5 THEN + FAILED ("INCORRECT RESULTS - 8"); + END IF; + OBJ_NEWT := 1.0; + OBJ_NEWT := OBJ_NEWT - 1.0; + IF OBJ_NEWT NOT IN NEW_T THEN + FAILED ("INCORRECT RESULTS - 9"); + END IF; + IF NEW_T'DIGITS /= 5 THEN + FAILED ("INCORRECT RESULTS - 10"); + END IF; + END; + + RESULT; +END CC3232A; diff --git a/gcc/testsuite/ada/acats/tests/cc/cc3233a.ada b/gcc/testsuite/ada/acats/tests/cc/cc3233a.ada new file mode 100644 index 000000000..c344cfc97 --- /dev/null +++ b/gcc/testsuite/ada/acats/tests/cc/cc3233a.ada @@ -0,0 +1,175 @@ +-- CC3233A.ADA + +-- Grant of Unlimited Rights +-- +-- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687, +-- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained +-- unlimited rights in the software and documentation contained herein. +-- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making +-- this public release, the Government intends to confer upon all +-- recipients unlimited rights equal to those held by the Government. +-- These rights include rights to use, duplicate, release or disclose the +-- released technical data and computer software in whole or in part, in +-- any manner and for any purpose whatsoever, and to have or permit others +-- to do so. +-- +-- DISCLAIMER +-- +-- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR +-- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED +-- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF 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 PRIVATE OR LIMITED PRIVATE FORMAL TYPE DENOTES ITS +-- ACTUAL PARAMETER, A FIXED POINT TYPE AND OPERATIONS OF THE FORMAL +-- TYPE ARE IDENTIFIED WITH CORRESPONDING OPERATIONS OF THE ACTUAL +-- TYPE. + +-- HISTORY: +-- TBN 09/15/88 CREATED ORIGINAL TEST. +-- PWN 01/31/95 REMOVED INCONSISTENCIES WITH ADA 9X. + +WITH REPORT; USE REPORT; +PROCEDURE CC3233A IS + + TYPE FIXED IS DELTA 0.125 RANGE 0.0 .. 10.0; + + GENERIC + TYPE T IS PRIVATE; + PACKAGE P IS + SUBTYPE SUB_T IS T; + PAC_VAR : T; + END P; + + GENERIC + TYPE T IS LIMITED PRIVATE; + PACKAGE LP IS + SUBTYPE SUB_T IS T; + PAC_VAR : T; + END LP; + + FUNCTION IDENT_FIX (X : FIXED) RETURN FIXED IS + BEGIN + IF EQUAL (3, 3) THEN + RETURN X; + ELSE + RETURN (0.0); + END IF; + END IDENT_FIX; + +BEGIN + TEST ("CC3233A", "CHECK THAT A PRIVATE OR LIMITED PRIVATE " & + "FORMAL TYPE DENOTES ITS ACTUAL PARAMETER, A " & + "FIXED POINT TYPE AND OPERATIONS OF THE FORMAL " & + "TYPE ARE IDENTIFIED WITH CORRESPONDING " & + "OPERATIONS OF THE ACTUAL TYPE"); + + DECLARE -- PRIVATE TYPE. + OBJ_INT : INTEGER := 1; + OBJ_FIX : FIXED := 1.0; + + PACKAGE P1 IS NEW P (FIXED); + USE P1; + + TYPE NEW_T IS NEW SUB_T; + OBJ_NEWT : NEW_T; + BEGIN + PAC_VAR := SUB_T'(1.0); + IF PAC_VAR /= OBJ_FIX THEN + FAILED ("INCORRECT RESULTS - 1"); + END IF; + OBJ_FIX := IDENT_FIX (PAC_VAR) + IDENT_FIX (OBJ_FIX); + IF OBJ_FIX <= PAC_VAR THEN + FAILED ("INCORRECT RESULTS - 2"); + END IF; + PAC_VAR := OBJ_INT * OBJ_FIX; + IF PAC_VAR NOT IN FIXED THEN + FAILED ("INCORRECT RESULTS - 3"); + END IF; + IF OBJ_FIX NOT IN SUB_T THEN + FAILED ("INCORRECT RESULTS - 4"); + END IF; + IF SUB_T'DELTA /= 0.125 THEN + FAILED ("INCORRECT RESULTS - 5"); + END IF; + OBJ_NEWT := 1.0; + OBJ_NEWT := OBJ_NEWT - 1.0; + IF OBJ_NEWT NOT IN NEW_T THEN + FAILED ("INCORRECT RESULTS - 6"); + END IF; + IF NEW_T'DELTA /= 0.125 THEN + FAILED ("INCORRECT RESULTS - 7"); + END IF; + OBJ_NEWT := NEW_T'SMALL + 1.0; + OBJ_FIX := 1.0; + OBJ_FIX := FIXED (OBJ_FIX * OBJ_FIX); + IF OBJ_FIX /= 1.0 THEN + FAILED ("INCORRECT RESULTS - 8"); + END IF; + OBJ_FIX := 1.0; + OBJ_FIX := SUB_T (OBJ_FIX / OBJ_FIX); + IF OBJ_FIX /= 1.0 THEN + FAILED ("INCORRECT RESULTS - 9"); + END IF; + IF FIXED'SMALL /= NEW_T'SMALL THEN + FAILED ("INCORRECT RESULTS - 10"); + END IF; + END; + + DECLARE -- LIMITED PRIVATE TYPE. + OBJ_INT : INTEGER := 1; + OBJ_FIX : FIXED := 1.0; + + PACKAGE P1 IS NEW LP (FIXED); + USE P1; + + TYPE NEW_T IS NEW SUB_T; + OBJ_NEWT : NEW_T; + BEGIN + PAC_VAR := SUB_T'(1.0); + IF PAC_VAR /= OBJ_FIX THEN + FAILED ("INCORRECT RESULTS - 1"); + END IF; + OBJ_FIX := IDENT_FIX (PAC_VAR) + IDENT_FIX (OBJ_FIX); + IF OBJ_FIX <= PAC_VAR THEN + FAILED ("INCORRECT RESULTS - 2"); + END IF; + PAC_VAR := OBJ_INT * OBJ_FIX; + IF PAC_VAR NOT IN FIXED THEN + FAILED ("INCORRECT RESULTS - 3"); + END IF; + IF OBJ_FIX NOT IN SUB_T THEN + FAILED ("INCORRECT RESULTS - 4"); + END IF; + IF SUB_T'DELTA /= 0.125 THEN + FAILED ("INCORRECT RESULTS - 5"); + END IF; + OBJ_NEWT := 1.0; + OBJ_NEWT := OBJ_NEWT - 1.0; + IF OBJ_NEWT NOT IN NEW_T THEN + FAILED ("INCORRECT RESULTS - 6"); + END IF; + IF NEW_T'DELTA /= 0.125 THEN + FAILED ("INCORRECT RESULTS - 7"); + END IF; + OBJ_NEWT := NEW_T'SMALL + 1.0; + OBJ_FIX := 1.0; + OBJ_FIX := FIXED (OBJ_FIX * OBJ_FIX); + IF OBJ_FIX /= 1.0 THEN + FAILED ("INCORRECT RESULTS - 8"); + END IF; + OBJ_FIX := 1.0; + OBJ_FIX := SUB_T (OBJ_FIX / OBJ_FIX); + IF OBJ_FIX /= 1.0 THEN + FAILED ("INCORRECT RESULTS - 9"); + END IF; + IF FIXED'SMALL /= NEW_T'SMALL THEN + FAILED ("INCORRECT RESULTS - 10"); + END IF; + END; + + RESULT; +END CC3233A; diff --git a/gcc/testsuite/ada/acats/tests/cc/cc3234a.ada b/gcc/testsuite/ada/acats/tests/cc/cc3234a.ada new file mode 100644 index 000000000..487b26c89 --- /dev/null +++ b/gcc/testsuite/ada/acats/tests/cc/cc3234a.ada @@ -0,0 +1,147 @@ +-- CC3234A.ADA + +-- Grant of Unlimited Rights +-- +-- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687, +-- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained +-- unlimited rights in the software and documentation contained herein. +-- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making +-- this public release, the Government intends to confer upon all +-- recipients unlimited rights equal to those held by the Government. +-- These rights include rights to use, duplicate, release or disclose the +-- released technical data and computer software in whole or in part, in +-- any manner and for any purpose whatsoever, and to have or permit others +-- to do so. +-- +-- DISCLAIMER +-- +-- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR +-- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED +-- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF 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 PRIVATE OR LIMITED PRIVATE FORMAL TYPE DENOTES ITS +-- ACTUAL PARAMETER AN ARRAY TYPE, AND OPERATIONS OF THE FORMAL +-- TYPE ARE IDENTIFIED WITH CORRESPONDING OPERATIONS OF THE ACTUAL +-- TYPE. + +-- HISTORY: +-- TBN 09/15/88 CREATED ORIGINAL TEST. + +WITH REPORT; USE REPORT; +PROCEDURE CC3234A IS + + GENERIC + TYPE T IS PRIVATE; + PACKAGE P IS + SUBTYPE SUB_T IS T; + PAC_VAR : T; + END P; + + GENERIC + TYPE T IS LIMITED PRIVATE; + PACKAGE LP IS + SUBTYPE SUB_T IS T; + PAC_VAR : T; + END LP; + +BEGIN + TEST ("CC3234A", "CHECK THAT A PRIVATE OR LIMITED PRIVATE " & + "FORMAL TYPE DENOTES ITS ACTUAL PARAMETER AN " & + "ARRAY TYPE, AND OPERATIONS OF THE " & + "FORMAL TYPE ARE IDENTIFIED WITH CORRESPONDING " & + "OPERATIONS OF THE ACTUAL TYPE"); + + DECLARE -- PRIVATE TYPE. + TYPE ARRAY_TYPE IS ARRAY (1..10) OF INTEGER; + + OBJ_ARR : ARRAY_TYPE := (OTHERS => 1); + + PACKAGE P1 IS NEW P (ARRAY_TYPE); + USE P1; + + TYPE NEW_T IS NEW SUB_T; + OBJ_NEWT : NEW_T; + BEGIN + PAC_VAR := SUB_T'(1, 1, 1, 1, 1, 1, 1, 1, 1, 1); + IF PAC_VAR /= OBJ_ARR THEN + FAILED ("INCORRECT RESULTS - 1"); + END IF; + OBJ_ARR(1) := PAC_VAR(2) + OBJ_ARR(1); + IF OBJ_ARR(1) <= PAC_VAR(1) THEN + FAILED ("INCORRECT RESULTS - 2"); + END IF; + PAC_VAR(1) := PAC_VAR(1) * OBJ_ARR(3); + IF PAC_VAR NOT IN ARRAY_TYPE THEN + FAILED ("INCORRECT RESULTS - 3"); + END IF; + IF OBJ_ARR NOT IN SUB_T THEN + FAILED ("INCORRECT RESULTS - 4"); + END IF; + IF ARRAY_TYPE'FIRST /= SUB_T'FIRST THEN + FAILED ("INCORRECT RESULTS - 5"); + END IF; + OBJ_ARR(1..5) := PAC_VAR(6..10); + IF OBJ_ARR(1..5) /= (1, 1, 1, 1, 1) THEN + FAILED ("INCORRECT RESULTS - 6"); + END IF; + PAC_VAR := (1, 1, 1, 1, 1, 2, 2, 2, 2, 2); + OBJ_NEWT := (1, 1, 1, 1, 1, 1, 1, 1, 1, 1); + OBJ_NEWT := NEW_T(PAC_VAR); + IF OBJ_NEWT(3..7) /= (1, 1, 1, 2, 2) THEN + FAILED ("INCORRECT RESULTS - 7"); + END IF; + IF OBJ_NEWT NOT IN NEW_T THEN + FAILED ("INCORRECT RESULTS - 8"); + END IF; + END; + + DECLARE -- LIMITED PRIVATE TYPE. + TYPE ARRAY_TYPE IS ARRAY (1..10) OF INTEGER; + + OBJ_ARR : ARRAY_TYPE := (OTHERS => 1); + + PACKAGE P1 IS NEW LP (ARRAY_TYPE); + USE P1; + + TYPE NEW_T IS NEW SUB_T; + OBJ_NEWT : NEW_T; + BEGIN + PAC_VAR := SUB_T'(1, 1, 1, 1, 1, 1, 1, 1, 1, 1); + IF PAC_VAR /= OBJ_ARR THEN + FAILED ("INCORRECT RESULTS - 9"); + END IF; + OBJ_ARR(1) := PAC_VAR(2) + OBJ_ARR(1); + IF OBJ_ARR(1) <= PAC_VAR(1) THEN + FAILED ("INCORRECT RESULTS - 10"); + END IF; + PAC_VAR(1) := PAC_VAR(1) * OBJ_ARR(3); + IF PAC_VAR NOT IN ARRAY_TYPE THEN + FAILED ("INCORRECT RESULTS - 11"); + END IF; + IF OBJ_ARR NOT IN SUB_T THEN + FAILED ("INCORRECT RESULTS - 12"); + END IF; + IF ARRAY_TYPE'FIRST /= SUB_T'FIRST THEN + FAILED ("INCORRECT RESULTS - 13"); + END IF; + OBJ_ARR(1..5) := PAC_VAR(6..10); + IF OBJ_ARR(1..5) /= (1, 1, 1, 1, 1) THEN + FAILED ("INCORRECT RESULTS - 14"); + END IF; + PAC_VAR := (1, 1, 1, 1, 1, 2, 2, 2, 2, 2); + OBJ_NEWT := (1, 1, 1, 1, 1, 1, 1, 1, 1, 1); + OBJ_NEWT := NEW_T(PAC_VAR); + IF OBJ_NEWT(3..7) /= (1, 1, 1, 2, 2) THEN + FAILED ("INCORRECT RESULTS - 15"); + END IF; + IF OBJ_NEWT NOT IN NEW_T THEN + FAILED ("INCORRECT RESULTS - 16"); + END IF; + END; + + RESULT; +END CC3234A; diff --git a/gcc/testsuite/ada/acats/tests/cc/cc3235a.ada b/gcc/testsuite/ada/acats/tests/cc/cc3235a.ada new file mode 100644 index 000000000..f32c3e128 --- /dev/null +++ b/gcc/testsuite/ada/acats/tests/cc/cc3235a.ada @@ -0,0 +1,129 @@ +-- CC3235A.ADA + +-- Grant of Unlimited Rights +-- +-- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687, +-- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained +-- unlimited rights in the software and documentation contained herein. +-- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making +-- this public release, the Government intends to confer upon all +-- recipients unlimited rights equal to those held by the Government. +-- These rights include rights to use, duplicate, release or disclose the +-- released technical data and computer software in whole or in part, in +-- any manner and for any purpose whatsoever, and to have or permit others +-- to do so. +-- +-- DISCLAIMER +-- +-- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR +-- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED +-- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF 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 PRIVATE OR LIMITED PRIVATE FORMAL TYPE DENOTES ITS +-- ACTUAL PARAMETER AN ACCESS TYPE, AND OPERATIONS OF THE FORMAL +-- TYPE ARE IDENTIFIED WITH CORRESPONDING OPERATIONS OF THE ACTUAL +-- TYPE. + +-- HISTORY: +-- TBN 09/15/88 CREATED ORIGINAL TEST. + +WITH REPORT; USE REPORT; +PROCEDURE CC3235A IS + + GENERIC + TYPE T IS PRIVATE; + PACKAGE P IS + SUBTYPE SUB_T IS T; + PAC_VAR : T; + END P; + + GENERIC + TYPE T IS LIMITED PRIVATE; + PACKAGE LP IS + SUBTYPE SUB_T IS T; + PAC_VAR : T; + END LP; + +BEGIN + TEST ("CC3235A", "CHECK THAT A PRIVATE OR LIMITED PRIVATE " & + "FORMAL TYPE DENOTES ITS ACTUAL PARAMETER AN " & + "ACCESS TYPE, AND OPERATIONS OF THE " & + "FORMAL TYPE ARE IDENTIFIED WITH CORRESPONDING " & + "OPERATIONS OF THE ACTUAL TYPE"); + + DECLARE -- PRIVATE TYPE. + TYPE ENUM IS (RED, YELLOW, GREEN, BLUE); + + TYPE ACCESS_TYPE IS ACCESS ENUM; + + OBJ_ACC : ACCESS_TYPE := NEW ENUM'(RED); + + PACKAGE P1 IS NEW P (ACCESS_TYPE); + USE P1; + + TYPE NEW_T IS NEW SUB_T; + OBJ_NEWT : NEW_T; + BEGIN + PAC_VAR := NEW ENUM'(RED); + IF (PAC_VAR.ALL < OBJ_ACC.ALL) OR + (PAC_VAR.ALL > OBJ_ACC.ALL) THEN + FAILED ("INCORRECT RESULTS - 1"); + END IF; + IF PAC_VAR NOT IN ACCESS_TYPE THEN + FAILED ("INCORRECT RESULTS - 2"); + END IF; + IF OBJ_ACC NOT IN SUB_T THEN + FAILED ("INCORRECT RESULTS - 3"); + END IF; + OBJ_ACC := NEW ENUM'(ENUM'SUCC(PAC_VAR.ALL)); + IF OBJ_ACC.ALL /= YELLOW THEN + FAILED ("INCORRECT RESULTS - 4"); + END IF; + OBJ_NEWT := NEW ENUM'(BLUE); + OBJ_NEWT := NEW ENUM'(ENUM'PRED(OBJ_NEWT.ALL)); + IF OBJ_NEWT NOT IN NEW_T THEN + FAILED ("INCORRECT RESULTS - 5"); + END IF; + END; + + DECLARE -- LIMITED PRIVATE TYPE. + TYPE ENUM IS (RED, YELLOW, GREEN, BLUE); + + TYPE ACCESS_TYPE IS ACCESS ENUM; + + OBJ_ACC : ACCESS_TYPE := NEW ENUM'(RED); + + PACKAGE P1 IS NEW LP (ACCESS_TYPE); + USE P1; + + TYPE NEW_T IS NEW SUB_T; + OBJ_NEWT : NEW_T; + BEGIN + PAC_VAR := NEW ENUM'(RED); + IF (PAC_VAR.ALL < OBJ_ACC.ALL) OR + (PAC_VAR.ALL > OBJ_ACC.ALL) THEN + FAILED ("INCORRECT RESULTS - 6"); + END IF; + IF PAC_VAR NOT IN ACCESS_TYPE THEN + FAILED ("INCORRECT RESULTS - 7"); + END IF; + IF OBJ_ACC NOT IN SUB_T THEN + FAILED ("INCORRECT RESULTS - 8"); + END IF; + OBJ_ACC := NEW ENUM'(ENUM'SUCC(PAC_VAR.ALL)); + IF OBJ_ACC.ALL /= YELLOW THEN + FAILED ("INCORRECT RESULTS - 9"); + END IF; + OBJ_NEWT := NEW ENUM'(BLUE); + OBJ_NEWT := NEW ENUM'(ENUM'PRED(OBJ_NEWT.ALL)); + IF OBJ_NEWT NOT IN NEW_T THEN + FAILED ("INCORRECT RESULTS - 10"); + END IF; + END; + + RESULT; +END CC3235A; diff --git a/gcc/testsuite/ada/acats/tests/cc/cc3236a.ada b/gcc/testsuite/ada/acats/tests/cc/cc3236a.ada new file mode 100644 index 000000000..d02dec25e --- /dev/null +++ b/gcc/testsuite/ada/acats/tests/cc/cc3236a.ada @@ -0,0 +1,117 @@ +-- CC3236A.ADA + +-- Grant of Unlimited Rights +-- +-- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687, +-- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained +-- unlimited rights in the software and documentation contained herein. +-- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making +-- this public release, the Government intends to confer upon all +-- recipients unlimited rights equal to those held by the Government. +-- These rights include rights to use, duplicate, release or disclose the +-- released technical data and computer software in whole or in part, in +-- any manner and for any purpose whatsoever, and to have or permit others +-- to do so. +-- +-- DISCLAIMER +-- +-- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR +-- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED +-- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF 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 PRIVATE AND LIMITED PRIVATE TYPE DENOTES ITS +-- ACTUAL PARAMETER, AND OPERATIONS OF THE FORMAL TYPE ARE +-- IDENTIFIED WITH CORRESPONDING OPERATIONS OF THE ACTUAL TYPE +-- WHEN THE ACTUAL PARAMETER IS A TYPE WITH DISCRIMINANTS. + +-- HISTORY: +-- DHH 10/24/88 CREATED ORIGINAL TEST. +-- PWN 02/02/95 REMOVED INCONSISTENCIES WITH ADA 9X. + +WITH REPORT; USE REPORT; +PROCEDURE CC3236A IS + + GENERIC + TYPE T IS PRIVATE; + PACKAGE P IS + SUBTYPE SUB_T IS T; + PAC_VAR : T; + END P; + + GENERIC + TYPE T IS LIMITED PRIVATE; + PACKAGE LP IS + SUBTYPE SUB_T IS T; + PAC_VAR : T; + END LP; + +BEGIN + TEST ("CC3236A", "CHECK THAT A FORMAL PRIVATE OR LIMITED " & + "PRIVATE TYPE DENOTES ITS ACTUAL PARAMETER AND " & + "OPERATIONS OF THE FORMAL TYPE ARE IDENTIFIED " & + "WITH CORRESPONDING OPERATIONS OF THE ACTUAL " & + "TYPE, WHEN THE ACTUAL PARAMETER IS A TYPE " & + "WITH DISCRIMINANTS"); + + DECLARE + TYPE REC(X : INTEGER := 5) IS + RECORD + NULL; + END RECORD; + OBJ_REC : REC(4); + + PACKAGE P2 IS NEW P (REC); + USE P2; + + TYPE NEW_T IS NEW SUB_T; + OBJ_NEWT : NEW_T(4); + BEGIN + PAC_VAR := SUB_T'((X => 4)); + IF PAC_VAR /= OBJ_REC THEN + FAILED ("INCORRECT RESULTS - 1"); + END IF; + IF PAC_VAR NOT IN REC THEN + FAILED ("INCORRECT RESULTS - 2"); + END IF; + IF OBJ_REC NOT IN SUB_T THEN + FAILED ("INCORRECT RESULTS - 3"); + END IF; + IF PAC_VAR.X /= OBJ_NEWT.X THEN + FAILED ("INCORRECT RESULTS - 4"); + END IF; + END; + + DECLARE + TYPE REC(X : INTEGER := 5) IS + RECORD + NULL; + END RECORD; + OBJ_REC : REC(4); + + PACKAGE P2 IS NEW LP (REC); + USE P2; + + TYPE NEW_T IS NEW SUB_T; + OBJ_NEWT : NEW_T(4); + BEGIN + PAC_VAR := SUB_T'(X => 4); + IF PAC_VAR /= OBJ_REC THEN + FAILED ("INCORRECT RESULTS - 7"); + END IF; + IF PAC_VAR NOT IN REC THEN + FAILED ("INCORRECT RESULTS - 8"); + END IF; + IF OBJ_REC NOT IN SUB_T THEN + FAILED ("INCORRECT RESULTS - 9"); + END IF; + IF PAC_VAR.X /= OBJ_NEWT.X THEN + FAILED ("INCORRECT RESULTS - 10"); + END IF; + END; + + RESULT; +END CC3236A; diff --git a/gcc/testsuite/ada/acats/tests/cc/cc3240a.ada b/gcc/testsuite/ada/acats/tests/cc/cc3240a.ada new file mode 100644 index 000000000..1983b9429 --- /dev/null +++ b/gcc/testsuite/ada/acats/tests/cc/cc3240a.ada @@ -0,0 +1,122 @@ +-- CC3240A.ADA + +-- Grant of Unlimited Rights +-- +-- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687, +-- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained +-- unlimited rights in the software and documentation contained herein. +-- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making +-- this public release, the Government intends to confer upon all +-- recipients unlimited rights equal to those held by the Government. +-- These rights include rights to use, duplicate, release or disclose the +-- released technical data and computer software in whole or in part, in +-- any manner and for any purpose whatsoever, and to have or permit others +-- to do so. +-- +-- DISCLAIMER +-- +-- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR +-- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED +-- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF 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 PRIVATE AND LIMITED PRIVATE TYPE DENOTES ITS +-- ACTUAL PARAMETER, AND OPERATIONS OF THE FORMAL TYPE ARE +-- IDENTIFIED WITH CORRESPONDING OPERATIONS OF THE ACTUAL TYPE +-- WHEN THE FORMAL TYPE IS A TYPE WITH DISCRIMINANTS. + +-- HISTORY: +-- RJW 10/13/88 CREATED ORIGINAL TEST. + +WITH REPORT; USE REPORT; +PROCEDURE CC3240A IS + +BEGIN + TEST ("CC3240A", "CHECK THAT A FORMAL PRIVATE OR LIMITED " & + "PRIVATE TYPE DENOTES ITS ACTUAL PARAMETER AND " & + "OPERATIONS OF THE FORMAL TYPE ARE IDENTIFIED " & + "WITH CORRESPONDING OPERATIONS OF THE ACTUAL " & + "TYPE, WHEN THE FORMAL TYPE IS A TYPE " & + "WITH DISCRIMINANTS"); + + DECLARE + + GENERIC + TYPE T(A : INTEGER) IS PRIVATE; + PACKAGE P IS + SUBTYPE S IS T; + TX : T(5); + END P; + + TYPE REC (L : INTEGER) IS + RECORD + A : INTEGER; + END RECORD; + + PACKAGE P1 IS NEW P (REC); + USE P1; + + BEGIN + TX := (L => 5, A => 7); + IF NOT (TX IN REC) THEN + FAILED ("MEMBERSHIP TEST - PRIVATE"); + END IF; + + IF TX.A /= 7 OR TX.L /= 5 THEN + FAILED ("SELECTED COMPONENTS - PRIVATE"); + END IF; + + IF S(TX) /= REC(TX) THEN + FAILED ("EXPLICIT CONVERSION - PRIVATE"); + END IF; + + IF NOT TX'CONSTRAINED THEN + FAILED ("'CONSTRAINED - PRIVATE"); + END IF; + END; + + DECLARE + TYPE REC(L : INTEGER) IS + RECORD + A : INTEGER; + END RECORD; + + GENERIC + TYPE T(A : INTEGER) IS LIMITED PRIVATE; + TX : IN OUT T; + PACKAGE LP IS + SUBTYPE S IS T; + END LP; + + R : REC (5) := (5, 7); + + PACKAGE BODY LP IS + BEGIN + IF (TX IN S) /= (R IN REC) THEN + FAILED ("MEMBERSHIP TEST - LIMITED PRIVATE"); + END IF; + + IF TX.A /= 5 THEN + FAILED ("SELECTED COMPONENTS - LIMITED PRIVATE"); + END IF; + + IF (S(TX) IN S) /= (REC(R) IN REC) THEN + FAILED ("EXPLICIT CONVERSION - LIMITED PRIVATE"); + END IF; + + IF NOT TX'CONSTRAINED THEN + FAILED ("'CONSTRAINED - LIMITED PRIVATE"); + END IF; + END LP; + + PACKAGE P1 IS NEW LP (REC, R); + USE P1; + BEGIN + NULL; + END; + + RESULT; +END CC3240A; diff --git a/gcc/testsuite/ada/acats/tests/cc/cc3305a.ada b/gcc/testsuite/ada/acats/tests/cc/cc3305a.ada new file mode 100644 index 000000000..66d0f38c4 --- /dev/null +++ b/gcc/testsuite/ada/acats/tests/cc/cc3305a.ada @@ -0,0 +1,103 @@ +-- CC3305A.ADA + +-- Grant of Unlimited Rights +-- +-- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687, +-- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained +-- unlimited rights in the software and documentation contained herein. +-- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making +-- this public release, the Government intends to confer upon all +-- recipients unlimited rights equal to those held by the Government. +-- These rights include rights to use, duplicate, release or disclose the +-- released technical data and computer software in whole or in part, in +-- any manner and for any purpose whatsoever, and to have or permit others +-- to do so. +-- +-- DISCLAIMER +-- +-- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR +-- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED +-- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF 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 WHEN A GENERIC FORMAL TYPE IS A SCALAR TYPE, THE BOUNDS OF +-- THE ACTUAL PARAMETER ARE USED WITHIN THE INSTANTIATED UNIT. + +-- CHECK WHEN THE SCALAR TYPE IS DEFINED BY (<>). + +-- SPS 7/15/82 + +WITH REPORT; +USE REPORT; + +PROCEDURE CC3305A IS +BEGIN + + TEST ("CC3305A", "TEST THE BOUNDS OF GENERIC FORMAL SCALAR " & + "TYPES OF THE FORM (<>)"); + + DECLARE + TYPE COLOR IS (RED, BLUE, YELLOW, ORANGE, GREEN, PURPLE); + SUBTYPE P_COLOR IS COLOR RANGE BLUE .. ORANGE; + SUBTYPE INT IS INTEGER RANGE 1 .. 3; + SUBTYPE ATOC IS CHARACTER RANGE CHARACTER'VAL(1) .. + CHARACTER'VAL(3); + + GENERIC + TYPE GFT IS (<>); + PACKAGE PK IS END PK; + + PACKAGE BODY PK IS + BEGIN + FOR I IN IDENT_INT(0) .. IDENT_INT(4) LOOP + COMMENT ("START OF ITERATION"); + DECLARE + VAR : GFT; + BEGIN + VAR := GFT'VAL (I); + IF I = 0 OR I = 4 THEN + FAILED ("CONSTRAINT_ERROR NOT RAISED"); + END IF; + EXCEPTION + WHEN CONSTRAINT_ERROR => + IF I /= 0 AND I /= 4 THEN + FAILED ("CONSTRAINT_ERROR RAISED " & + "INAPPROPRIATELY"); + END IF; + END; + END LOOP; + END PK; + + BEGIN + COMMENT ("INSTANTIATION WITH P_COLOR"); + DECLARE + PACKAGE NPC IS NEW PK (P_COLOR); + BEGIN + NULL; + END; + + COMMENT ("INSTANTIATION WITH INT"); + + DECLARE + PACKAGE NPI IS NEW PK (INT); + BEGIN + NULL; + END; + + COMMENT ("INSTANTIATION WITH ATOC"); + + DECLARE + PACKAGE NPA IS NEW PK (ATOC); + BEGIN + NULL; + END; + + EXCEPTION + WHEN CONSTRAINT_ERROR => + FAILED ("CONSTRAINT_ERROR RAISED ON INSTANTIATION"); + END; + + RESULT; +END CC3305A; diff --git a/gcc/testsuite/ada/acats/tests/cc/cc3305b.ada b/gcc/testsuite/ada/acats/tests/cc/cc3305b.ada new file mode 100644 index 000000000..7273c689e --- /dev/null +++ b/gcc/testsuite/ada/acats/tests/cc/cc3305b.ada @@ -0,0 +1,84 @@ +-- CC3305B.ADA + +-- Grant of Unlimited Rights +-- +-- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687, +-- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained +-- unlimited rights in the software and documentation contained herein. +-- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making +-- this public release, the Government intends to confer upon all +-- recipients unlimited rights equal to those held by the Government. +-- These rights include rights to use, duplicate, release or disclose the +-- released technical data and computer software in whole or in part, in +-- any manner and for any purpose whatsoever, and to have or permit others +-- to do so. +-- +-- DISCLAIMER +-- +-- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR +-- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED +-- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF 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 WHEN A GENERIC FORMAL TYPE IS A SCALAR TYPE, THE BOUNDS OF +-- THE ACTUAL PARAMETER ARE USED WITHIN THE INSTANTIATED UNIT. + +-- CHECK WHEN THE SCALAR TYPE IS DEFINED BY RANGE <>. + +-- SPS 7/15/82 + +WITH REPORT; +USE REPORT; + +PROCEDURE CC3305B IS +BEGIN + + TEST ("CC3305B", "TEST THE BOUNDS OF GENERIC FORMAL SCALAR " & + "TYPES OF THE FORM RANGE <>"); + + DECLARE + SUBTYPE INT IS INTEGER RANGE 1 .. 3; + + GENERIC + TYPE GFT IS RANGE <>; + PACKAGE PK IS END PK; + + PACKAGE BODY PK IS + BEGIN + FOR I IN IDENT_INT(0) .. IDENT_INT(4) LOOP + COMMENT ("START OF ITERATION"); + DECLARE + VAR : GFT; + BEGIN + VAR := GFT(I); + IF I = IDENT_INT(0) OR I = IDENT_INT(4) THEN + FAILED ("CONSTRAINT_ERROR NOT RAISED"); + END IF; + EXCEPTION + WHEN CONSTRAINT_ERROR => + IF I /= IDENT_INT(0) AND + I /= IDENT_INT(4) THEN + FAILED ("CONSTRAINT_ERROR RAISED " & + "INAPPROPRIATELY"); + END IF; + END; + END LOOP; + END PK; + + BEGIN + + DECLARE + PACKAGE NPI IS NEW PK (INT); + BEGIN + NULL; + END; + + EXCEPTION + WHEN CONSTRAINT_ERROR => + FAILED ("CONSTRAINT_ERROR RAISED ON INSTANTIATION"); + END; + + RESULT; +END CC3305B; diff --git a/gcc/testsuite/ada/acats/tests/cc/cc3305c.ada b/gcc/testsuite/ada/acats/tests/cc/cc3305c.ada new file mode 100644 index 000000000..6cb53a87b --- /dev/null +++ b/gcc/testsuite/ada/acats/tests/cc/cc3305c.ada @@ -0,0 +1,84 @@ +-- CC3305C.ADA + +-- Grant of Unlimited Rights +-- +-- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687, +-- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained +-- unlimited rights in the software and documentation contained herein. +-- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making +-- this public release, the Government intends to confer upon all +-- recipients unlimited rights equal to those held by the Government. +-- These rights include rights to use, duplicate, release or disclose the +-- released technical data and computer software in whole or in part, in +-- any manner and for any purpose whatsoever, and to have or permit others +-- to do so. +-- +-- DISCLAIMER +-- +-- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR +-- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED +-- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF 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 WHEN A GENERIC FORMAL TYPE IS A SCALAR TYPE, THE BOUNDS OF +-- THE ACTUAL PARAMETER ARE USED WITHIN THE INSTANTIATED UNIT. + +-- CHECK WHEN THE SCALAR TYPE IS DEFINED BY DIGITS <>. + +-- SPS 7/15/82 + +WITH REPORT; +USE REPORT; + +PROCEDURE CC3305C IS +BEGIN + + TEST ("CC3305C", "TEST THE BOUNDS OF GENERIC FORMAL SCALAR " & + "TYPES OF THE FORM DIGITS <>"); + + DECLARE + SUBTYPE FL IS FLOAT RANGE 1.0 .. 3.0; + + GENERIC + TYPE GFT IS DIGITS <>; + PACKAGE PK IS END PK; + + PACKAGE BODY PK IS + BEGIN + FOR I IN IDENT_INT(0) .. IDENT_INT(4) LOOP + COMMENT ("START OF ITERATION"); + DECLARE + VAR : GFT; + BEGIN + VAR := GFT (I); + IF I = IDENT_INT(0) OR I = IDENT_INT(4) THEN + FAILED ("CONSTRAINT_ERROR NOT RAISED"); + END IF; + EXCEPTION + WHEN CONSTRAINT_ERROR => + IF I /= IDENT_INT(0) AND + I /= IDENT_INT(4) THEN + FAILED ("CONSTRAINT_ERROR RAISED " & + "INAPPROPRIATELY"); + END IF; + END; + END LOOP; + END PK; + + BEGIN + + DECLARE + PACKAGE NP IS NEW PK (FL); + BEGIN + NULL; + END; + + EXCEPTION + WHEN CONSTRAINT_ERROR => + FAILED ("CONSTRAINT_ERROR RAISED ON INSTANTIATION"); + END; + + RESULT; +END CC3305C; diff --git a/gcc/testsuite/ada/acats/tests/cc/cc3305d.ada b/gcc/testsuite/ada/acats/tests/cc/cc3305d.ada new file mode 100644 index 000000000..1faa64f62 --- /dev/null +++ b/gcc/testsuite/ada/acats/tests/cc/cc3305d.ada @@ -0,0 +1,84 @@ +-- CC3305D.ADA + +-- Grant of Unlimited Rights +-- +-- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687, +-- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained +-- unlimited rights in the software and documentation contained herein. +-- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making +-- this public release, the Government intends to confer upon all +-- recipients unlimited rights equal to those held by the Government. +-- These rights include rights to use, duplicate, release or disclose the +-- released technical data and computer software in whole or in part, in +-- any manner and for any purpose whatsoever, and to have or permit others +-- to do so. +-- +-- DISCLAIMER +-- +-- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR +-- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED +-- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF 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 WHEN A GENERIC FORMAL TYPE IS A SCALAR TYPE, THE BOUNDS OF +-- THE ACTUAL PARAMETER ARE USED WITHIN THE INSTANTIATED UNIT. + +-- CHECK WHEN THE SCALAR TYPE IS DEFINED BY DELTA <>. + +-- SPS 7/15/82 + +WITH REPORT; +USE REPORT; + +PROCEDURE CC3305D IS +BEGIN + + TEST ("CC3305D", "TEST THE BOUNDS OF GENERIC FORMAL SCALAR " & + "TYPES OF THE FORM DELTA <>"); + + DECLARE + TYPE FX IS DELTA 0.1 RANGE 1.0 .. 3.0; + + GENERIC + TYPE GFT IS DELTA <>; + PACKAGE PK IS END PK; + + PACKAGE BODY PK IS + BEGIN + FOR I IN IDENT_INT(0) .. IDENT_INT(4) LOOP + COMMENT ("START OF ITERATION"); + DECLARE + VAR : GFT; + BEGIN + VAR := GFT (I); + IF I = IDENT_INT(0) OR I = IDENT_INT(4) THEN + FAILED ("CONSTRAINT_ERROR NOT RAISED"); + END IF; + EXCEPTION + WHEN CONSTRAINT_ERROR => + IF I /= IDENT_INT(0) AND + I /= IDENT_INT(4) THEN + FAILED ("CONSTRAINT_ERROR RAISED " & + "INAPPROPRIATELY"); + END IF; + END; + END LOOP; + END PK; + + BEGIN + + DECLARE + PACKAGE NP IS NEW PK (FX); + BEGIN + NULL; + END; + + EXCEPTION + WHEN CONSTRAINT_ERROR => + FAILED ("CONSTRAINT_ERROR RAISED ON INSTANTIATION"); + END; + + RESULT; +END CC3305D; diff --git a/gcc/testsuite/ada/acats/tests/cc/cc3601a.ada b/gcc/testsuite/ada/acats/tests/cc/cc3601a.ada new file mode 100644 index 000000000..198f47ecd --- /dev/null +++ b/gcc/testsuite/ada/acats/tests/cc/cc3601a.ada @@ -0,0 +1,251 @@ +-- CC3601A.ADA + +-- Grant of Unlimited Rights +-- +-- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687, +-- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained +-- unlimited rights in the software and documentation contained herein. +-- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making +-- this public release, the Government intends to confer upon all +-- recipients unlimited rights equal to those held by the Government. +-- These rights include rights to use, duplicate, release or disclose the +-- released technical data and computer software in whole or in part, in +-- any manner and for any purpose whatsoever, and to have or permit others +-- to do so. +-- +-- DISCLAIMER +-- +-- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR +-- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED +-- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF 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 PREDEFINED OPERATORS MAY BE PASSED AS ACTUAL +-- GENERIC SUBPROGRAM PARAMETERS (CHECKS FOR "=" AND "/=" ARE IN +-- CC3601C). + +-- R.WILLIAMS 10/9/86 +-- JRL 11/15/95 Added unknown discriminant part to all formal +-- private types. + + +WITH REPORT; USE REPORT; +PROCEDURE CC3601A IS + + GENERIC + TYPE T (<>) IS PRIVATE; + V, V1 : T; + KIND : STRING; + WITH FUNCTION F1 (X : IN T) RETURN T; + PACKAGE GP1 IS + R : BOOLEAN := F1 (V) = V1; + END GP1; + + PACKAGE BODY GP1 IS + BEGIN + IF NOT (IDENT_BOOL(R)) THEN + FAILED ( "INCORRECT VALUE FOR UNARY OP - " & KIND); + END IF; + END GP1; + + GENERIC + TYPE T (<>) IS PRIVATE; + V, V1, V2 : IN T; + KIND : STRING; + WITH FUNCTION F1 (P1 : IN T; P2 : IN T) RETURN T; + PACKAGE GP2 IS + R : BOOLEAN := V /= F1 (V1, V2); + END GP2; + + PACKAGE BODY GP2 IS + BEGIN + IF IDENT_BOOL (R) THEN + FAILED ( "INCORRECT VALUE FOR BINARY OP - " & KIND); + END IF; + END GP2; + + + GENERIC + TYPE T1 (<>) IS PRIVATE; + TYPE T2 (<>) IS PRIVATE; + V1 : T1; + V2 : T2; + KIND : STRING; + WITH FUNCTION F1 (X : IN T1) RETURN T2; + PACKAGE GP3 IS + R : BOOLEAN := F1 (V1) = V2; + END GP3; + + PACKAGE BODY GP3 IS + BEGIN + IF NOT (IDENT_BOOL(R)) THEN + FAILED ( "INCORRECT VALUE FOR OP - " & KIND); + END IF; + END GP3; + +BEGIN + TEST ( "CC3601A", "CHECK THAT PREDEFINED OPERATORS MAY BE " & + "PASSED AS ACTUAL GENERIC SUBPROGRAM " & + "PARAMETERS" ); + + + BEGIN -- CHECKS WITH RELATIONAL OPERATORS AND LOGICAL OPERATORS AS + -- ACTUAL PARAMETERS. + + FOR I1 IN BOOLEAN LOOP + + FOR I2 IN BOOLEAN LOOP + COMMENT ( "B1 = " & BOOLEAN'IMAGE (I1) & " AND " & + "B2 = " & BOOLEAN'IMAGE (I2) ); + DECLARE + B1 : BOOLEAN := IDENT_BOOL (I1); + B2 : BOOLEAN := IDENT_BOOL (I2); + + PACKAGE P1 IS + NEW GP1 (BOOLEAN, NOT B2, B2, + """NOT"" - 1", "NOT"); + PACKAGE P2 IS + NEW GP2 (BOOLEAN, B1 OR B2, B1, B2, + "OR", "OR"); + PACKAGE P3 IS + NEW GP2 (BOOLEAN, B1 AND B2, B2, B1, + "AND", "AND"); + PACKAGE P4 IS + NEW GP2 (BOOLEAN, B1 /= B2, B1, B2, + "XOR", "XOR"); + PACKAGE P5 IS + NEW GP2 (BOOLEAN, B1 < B2, B1, B2, + "<", "<"); + PACKAGE P6 IS + NEW GP2 (BOOLEAN, B1 <= B2, B1, B2, + "<=", "<="); + PACKAGE P7 IS + NEW GP2 (BOOLEAN, B1 > B2, B1, B2, + ">", ">"); + PACKAGE P8 IS + NEW GP2 (BOOLEAN, B1 >= B2, B1, B2, + ">=", ">="); + + TYPE AB IS ARRAY (BOOLEAN RANGE <> ) + OF BOOLEAN; + AB1 : AB (BOOLEAN) := (B1, B2); + AB2 : AB (BOOLEAN) := (B2, B1); + T : AB (B1 .. B2) := (B1 .. B2 => TRUE); + F : AB (B1 .. B2) := (B1 .. B2 => FALSE); + VB1 : AB (B1 .. B1) := (B1 => B2); + VB2 : AB (B2 .. B2) := (B2 => B1); + + PACKAGE P9 IS + NEW GP1 (AB, AB1, NOT AB1, + """NOT"" - 2", "NOT"); + PACKAGE P10 IS + NEW GP1 (AB, T, F, + """NOT"" - 3", "NOT"); + PACKAGE P11 IS + NEW GP1 (AB, VB2, (B2 => NOT B1), + """NOT"" - 4", "NOT"); + PACKAGE P12 IS + NEW GP2 (AB, AB1 AND AB2, AB1, AB2, + "AND", "AND"); + BEGIN + NULL; + END; + END LOOP; + END LOOP; + END; + + DECLARE -- CHECKS WITH ADDING AND MULTIPLYING OPERATORS, "**", + -- AND "ABS". + + PACKAGE P1 IS NEW GP1 (INTEGER, -4, -4, """+"" - 1", "+"); + + PACKAGE P2 IS NEW GP1 (FLOAT, 4.0, 4.0, """+"" - 2", "+"); + + PACKAGE P3 IS NEW GP1 (DURATION, -4.0, -4.0, """+"" - 3", + "+"); + PACKAGE P4 IS NEW GP1 (INTEGER, -4, 4, """-"" - 1", "-"); + + PACKAGE P5 IS NEW GP1 (FLOAT, 0.0, 0.0, """-"" - 2", "-"); + + PACKAGE P6 IS NEW GP1 (DURATION, 1.0, -1.0, """-"" - 3", + "-"); + PACKAGE P7 IS NEW GP2 (INTEGER, 6, 1, 5, """+"" - 1", "+"); + + PACKAGE P8 IS NEW GP2 (FLOAT, 6.0, 1.0, 5.0, """+"" - 2", + "+"); + PACKAGE P9 IS NEW GP2 (DURATION, 6.0, 1.0, 5.0, """+"" - 3", + "+"); + PACKAGE P10 IS NEW GP2 (INTEGER, 1, 6, 5, """-"" - 1", + "-" ); + PACKAGE P11 IS NEW GP2 (DURATION, 11.0, 6.0,-5.0, + """-"" - 2", "-"); + PACKAGE P12 IS NEW GP2 (FLOAT, 1.0, 6.0, 5.0, """-"" - 3", + "-"); + + SUBTYPE SUBINT IS INTEGER RANGE 0 .. 2; + TYPE STR IS ARRAY (SUBINT RANGE <>) OF CHARACTER; + VSTR : STR (0 .. 1) := "AB"; + + PACKAGE P13 IS NEW GP2 (STR, VSTR (0 .. 0) & + VSTR (1 .. 1), + VSTR (0 .. 0), + VSTR (1 .. 1), """&"" - 1", "&"); + + PACKAGE P14 IS NEW GP2 (STR, VSTR (1 .. 1) & + VSTR (0 .. 0), + VSTR (1 .. 1), + VSTR (0 .. 0), """&"" - 2", "&"); + + PACKAGE P15 IS NEW GP2 (INTEGER, 0, -1, 0, """*"" - 1", "*"); + + PACKAGE P16 IS NEW GP2 (FLOAT, 6.0, 3.0, 2.0, """*"" - 2", + "*"); + PACKAGE P17 IS NEW GP2 (INTEGER, 0, 0, 6, """/"" - 1", "/"); + + PACKAGE P18 IS NEW GP2 (FLOAT, 3.0, 6.0, 2.0, """/"" - 2", + "/"); + PACKAGE P19 IS NEW GP2 (INTEGER, -1, -11, 5, "REM", "REM"); + + PACKAGE P20 IS NEW GP2 (INTEGER, 4, -11, 5, "MOD", "MOD"); + + PACKAGE P21 IS NEW GP1 (INTEGER, 5, 5, """ABS"" - 1", "ABS"); + + PACKAGE P22 IS NEW GP1 (FLOAT, -5.0, 5.0, """ABS"" - 2", + "ABS"); + + PACKAGE P23 IS NEW GP1 (DURATION, 0.0, 0.0, """ABS"" - 3", + "ABS"); + + PACKAGE P24 IS NEW GP2 (INTEGER, 9, 3, 2, """**"" - 1", + "**"); + + PACKAGE P25 IS NEW GP2 (INTEGER, 1, 5, 0, """**"" - 2", + "**"); + + BEGIN + NULL; + END; + + DECLARE -- CHECKS WITH ATTRIBUTES. + + TYPE WEEKDAY IS (MON, TUES, WED, THUR, FRI); + + PACKAGE P1 IS NEW GP1 (WEEKDAY, TUES, WED, "WEEKDAY'SUCC", + WEEKDAY'SUCC); + + PACKAGE P2 IS NEW GP1 (WEEKDAY, TUES, MON, "WEEKDAY'PRED", + WEEKDAY'PRED); + + PACKAGE P3 IS NEW GP3 (WEEKDAY, STRING, THUR, "THUR", + "WEEKDAY'IMAGE", WEEKDAY'IMAGE); + + PACKAGE P4 IS NEW GP3 (STRING, WEEKDAY, "FRI", FRI, + "WEEKDAY'VALUE", WEEKDAY'VALUE); + BEGIN + NULL; + END; + + RESULT; +END CC3601A; diff --git a/gcc/testsuite/ada/acats/tests/cc/cc3601c.ada b/gcc/testsuite/ada/acats/tests/cc/cc3601c.ada new file mode 100644 index 000000000..a0119776d --- /dev/null +++ b/gcc/testsuite/ada/acats/tests/cc/cc3601c.ada @@ -0,0 +1,149 @@ +-- CC3601C.ADA + +-- Grant of Unlimited Rights +-- +-- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687, +-- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained +-- unlimited rights in the software and documentation contained herein. +-- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making +-- this public release, the Government intends to confer upon all +-- recipients unlimited rights equal to those held by the Government. +-- These rights include rights to use, duplicate, release or disclose the +-- released technical data and computer software in whole or in part, in +-- any manner and for any purpose whatsoever, and to have or permit others +-- to do so. +-- +-- DISCLAIMER +-- +-- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR +-- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED +-- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF 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 "/=" MAY BE PASSED AS A GENERIC ACTUAL FUNCTION +-- PARAMETER. + +-- DAT 10/6/81 +-- SPS 10/27/82 +-- JRK 2/9/83 + +WITH REPORT; USE REPORT; + +PROCEDURE CC3601C IS +BEGIN + TEST ("CC3601C", "/= AS GENERIC ACTUAL PARAMETER"); + + DECLARE + PACKAGE PK IS + TYPE LP IS LIMITED PRIVATE; + FUNCTION "=" (X, Y : LP) RETURN BOOLEAN;-- RETURNS FALSE. + TYPE INT IS NEW INTEGER; + PRIVATE + TASK TYPE LP; + END PK; + USE PK; + + V1, V2 : LP; + + TYPE REC IS RECORD + C : LP; + END RECORD; + + R1, R2 : REC; + + TYPE INT IS NEW INTEGER; + + B1 : BOOLEAN := TRUE; + B2 : BOOLEAN := TRUE; + INTEGER_3 : INTEGER := 3; + INTEGER_4 : INTEGER := 4; + INT_3 : INT := 3; + INT_4 : INT := 4; + INT_5 : INT := 5; + PK_INT_M1 : PK.INT := -1; + PK_INT_M2 : PK.INT := -2; + PK_INT_1 : PK.INT := 1; + PK_INT_2 : PK.INT := 2; + PK_INT_3 : PK.INT := 3; + + FUNCTION "=" (Q, R : LP) RETURN BOOLEAN;-- RETURNS TRUE. + + GENERIC + TYPE T IS LIMITED PRIVATE; + V1, V2 : IN OUT T; + WITH FUNCTION NE (ZA : IN T; ZB : T) RETURN BOOLEAN; + VALUE : IN BOOLEAN; -- SHOULD BE VALUE OF NE(V1,V2). + STR : STRING; + PACKAGE GP IS END GP; + + FUNCTION "=" (Q, R : IN REC) RETURN BOOLEAN; + + FUNCTION NE (Q : INT; R : IN INT) RETURN BOOLEAN + RENAMES "/="; + + FUNCTION NE (Q : PK.INT; R : IN PK.INT) RETURN BOOLEAN + RENAMES "/="; + + PACKAGE BODY GP IS + BEGIN + IF IDENT_BOOL(VALUE) /= NE (V1, V2) THEN + FAILED ("WRONG /= ACTUAL GENERIC PARAMETER " + & STR); + END IF; + END GP; + + FUNCTION "=" (Q, R : IN REC) RETURN BOOLEAN IS + BEGIN + RETURN FALSE; + END "="; + + FUNCTION "=" (Q, R : LP) RETURN BOOLEAN IS + BEGIN + RETURN TRUE; + END "="; + + PACKAGE BODY PK IS + FUNCTION "=" (X, Y : LP) RETURN BOOLEAN IS + BEGIN + RETURN R1 = R1; -- FALSE. + END "="; + TASK BODY LP IS BEGIN NULL; END; + END PK; + + PACKAGE P1 IS NEW GP (LP, V1, V2, "/=", FALSE, "1"); + + FUNCTION "NOT" (X : BOOLEAN) RETURN BOOLEAN IS + BEGIN RETURN X; END "NOT"; -- ENSURES USE OF PREDEFINED "NOT" + + PACKAGE P2 IS NEW GP (LP, V1, V2, "/=", FALSE, "2"); + PACKAGE P3 IS NEW GP (LP, V1, V2, PK."/=", TRUE, "3"); + PACKAGE P4 IS NEW GP (PK.LP, V1, V2, "/=", FALSE, "4"); + PACKAGE P5 IS NEW GP (PK.LP, V1, V2, PK."/=", TRUE, "5"); + PACKAGE P6 IS NEW GP (REC, R1, R2, "/=", TRUE, "6"); + PACKAGE P7 IS NEW GP (INTEGER, INTEGER_3, INTEGER_4, "/=", + TRUE, "7"); + PACKAGE P8 IS NEW GP (BOOLEAN, B1, B2, "/=", FALSE,"8"); + PACKAGE P9 IS NEW GP (INT, INT_3, INT_5, "/=", TRUE, "9"); + PACKAGE P10 IS NEW GP (INT, INT_3, INT_3, "/=", FALSE, "10"); + PACKAGE P11 IS NEW GP (INT, INT_3, INT_4, NE, TRUE, "11"); + PACKAGE P12 IS NEW GP (INT, INT_3, INT_3, NE, FALSE, "12"); + PACKAGE P13 IS NEW GP (PK.INT, PK_INT_3, PK_INT_3, NE, + FALSE, "13"); + PACKAGE P14 IS NEW GP (PK.INT, PK_INT_M1, PK_INT_M2, NE, + TRUE, "14"); + PACKAGE P15 IS NEW GP (PK.INT, PK_INT_1, PK_INT_1, "/=", + FALSE, "15"); + PACKAGE P16 IS NEW GP (PK.INT, PK_INT_1, PK_INT_2, "/=", + TRUE, "16"); + PACKAGE P17 IS NEW GP (PK.INT, PK_INT_1, PK_INT_1, PK."/=", + FALSE, "17"); + PACKAGE P18 IS NEW GP (PK.INT, PK_INT_1, PK_INT_2, PK."/=", + TRUE, "18"); + BEGIN + NULL; + END; + + RESULT; +END CC3601C; diff --git a/gcc/testsuite/ada/acats/tests/cc/cc3602a.ada b/gcc/testsuite/ada/acats/tests/cc/cc3602a.ada new file mode 100644 index 000000000..005995e99 --- /dev/null +++ b/gcc/testsuite/ada/acats/tests/cc/cc3602a.ada @@ -0,0 +1,146 @@ +-- CC3602A.ADA + +-- Grant of Unlimited Rights +-- +-- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687, +-- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained +-- unlimited rights in the software and documentation contained herein. +-- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making +-- this public release, the Government intends to confer upon all +-- recipients unlimited rights equal to those held by the Government. +-- These rights include rights to use, duplicate, release or disclose the +-- released technical data and computer software in whole or in part, in +-- any manner and for any purpose whatsoever, and to have or permit others +-- to do so. +-- +-- DISCLAIMER +-- +-- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR +-- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED +-- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF 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 ENTRIES MAY BE PASSED AS GENERIC SUBPROGRAM +-- PARAMETERS. + +-- HISTORY: +-- DAT 9/25/81 CREATED ORIGINAL TEST. +-- LDC 10/6/88 REVISED; CHECKED THAT DEFAULT NAME CAN BE +-- IDENTIFIED WITH ENTRY. + + +WITH REPORT; USE REPORT; + +PROCEDURE CC3602A IS + COUNTER : INTEGER := 0; +BEGIN + TEST ("CC3602A", "ENTRIES AS GENERIC SUBPROGRAM PARAMETERS"); + + DECLARE + TASK TSK IS + ENTRY ENT; + END TSK; + + GENERIC + WITH PROCEDURE P; + PROCEDURE GP; + + GENERIC + WITH PROCEDURE P; + PACKAGE PK IS END PK; + + + PROCEDURE E1 RENAMES TSK.ENT; + + GENERIC + WITH PROCEDURE P IS TSK.ENT; + PROCEDURE GP_DEF1; + + GENERIC + WITH PROCEDURE P IS E1; + PROCEDURE GP_DEF2; + + GENERIC + WITH PROCEDURE P IS TSK.ENT; + PACKAGE PK_DEF1 IS END PK_DEF1; + + GENERIC + WITH PROCEDURE P IS E1; + PACKAGE PK_DEF2 IS END PK_DEF2; + + PROCEDURE GP IS + BEGIN + P; + END GP; + + PACKAGE BODY PK IS + BEGIN + P; + END PK; + + + PROCEDURE GP_DEF1 IS + BEGIN + P; + END GP_DEF1; + + PROCEDURE GP_DEF2 IS + BEGIN + P; + END GP_DEF2; + + PACKAGE BODY PK_DEF1 IS + BEGIN + P; + END PK_DEF1; + + PACKAGE BODY PK_DEF2 IS + BEGIN + P; + END PK_DEF2; + + TASK BODY TSK IS + BEGIN + LOOP + SELECT + ACCEPT ENT DO + COUNTER := COUNTER + 1; + END ENT; + OR + TERMINATE; + END SELECT; + END LOOP; + END TSK; + + BEGIN + DECLARE + PROCEDURE P1 IS NEW GP (TSK.ENT); + PROCEDURE E RENAMES TSK.ENT; + PROCEDURE P2 IS NEW GP (E); + PACKAGE PK1 IS NEW PK (TSK.ENT); + PACKAGE PK2 IS NEW PK (E); + + PROCEDURE P3 IS NEW GP_DEF1; + PROCEDURE P4 IS NEW GP_DEF2; + PACKAGE PK3 IS NEW PK_DEF1; + PACKAGE PK4 IS NEW PK_DEF2; + BEGIN + P1; + P2; + TSK.ENT; + E; + P3; + P4; + END; + TSK.ENT; + END; + + IF COUNTER /= 11 THEN + FAILED ("INCORRECT CALL OF ENTRY AS GENERIC PARAMETER"); + END IF; + + RESULT; +END CC3602A; diff --git a/gcc/testsuite/ada/acats/tests/cc/cc3603a.ada b/gcc/testsuite/ada/acats/tests/cc/cc3603a.ada new file mode 100644 index 000000000..45e65b25f --- /dev/null +++ b/gcc/testsuite/ada/acats/tests/cc/cc3603a.ada @@ -0,0 +1,97 @@ +-- CC3603A.ADA + +-- Grant of Unlimited Rights +-- +-- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687, +-- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained +-- unlimited rights in the software and documentation contained herein. +-- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making +-- this public release, the Government intends to confer upon all +-- recipients unlimited rights equal to those held by the Government. +-- These rights include rights to use, duplicate, release or disclose the +-- released technical data and computer software in whole or in part, in +-- any manner and for any purpose whatsoever, and to have or permit others +-- to do so. +-- +-- DISCLAIMER +-- +-- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR +-- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED +-- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF 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 ENUMERATION LITERALS (BOTH IDENTIFIERS AND CHARACTER +-- LITERALS) MAY BE PASSED AS ACTUALS CORRESPONDING TO GENERIC +-- FORMAL SUBPROGRAMS. + +-- HISTORY: +-- RJW 06/11/86 CREATED ORIGINAL TEST. +-- VCL 08/18/87 CHANGED THE SECOND ACTUAL GENERIC PARAMETER IN THE +-- INSTANTIATION OF PROCEDURE NP3 TO +-- 'IDENT_CHAR('X')'. + +WITH REPORT; USE REPORT; + +PROCEDURE CC3603A IS + +BEGIN + TEST ("CC3603A", "CHECK THAT ENUMERATION LITERALS (BOTH " & + "IDENTIFIERS AND CHARACTER LITERALS) MAY " & + "BE PASSED AS ACTUALS CORRESPONDING TO " & + "GENERIC FORMAL SUBPROGRAMS" ); + + DECLARE + + TYPE ENUM1 IS ('A', 'B'); + TYPE ENUM2 IS (C, D); + + GENERIC + TYPE E IS (<>); + E1 : E; + WITH FUNCTION F RETURN E; + PROCEDURE P; + + PROCEDURE P IS + BEGIN + IF F /= E1 THEN + FAILED ( "WRONG VALUE FOR " & E'IMAGE (E1) & + " AS ACTUAL PARAMETER" ); + END IF; + EXCEPTION + WHEN OTHERS => + FAILED ( "EXCEPTION RAISED INSIDE OF P WITH " & + E'IMAGE (E1) & + " AS ACTUAL PARAMETER" ); + END P; + + PROCEDURE NP1 IS NEW P (ENUM1, 'A', 'A'); + PROCEDURE NP2 IS NEW P (ENUM2, D, D); + PROCEDURE NP3 IS NEW P (CHARACTER, IDENT_CHAR('X'), 'X'); + BEGIN + BEGIN + NP1; + EXCEPTION + WHEN OTHERS => + FAILED ( "EXCEPTION RAISED WHEN NP1 CALLED" ); + END; + + BEGIN + NP2; + EXCEPTION + WHEN OTHERS => + FAILED ( "EXCEPTION RAISED WHEN NP2 CALLED" ); + END; + + BEGIN + NP3; + EXCEPTION + WHEN OTHERS => + FAILED ( "EXCEPTION RAISED WHEN NP3 CALLED" ); + END; + END; + RESULT; + +END CC3603A; diff --git a/gcc/testsuite/ada/acats/tests/cc/cc3605a.ada b/gcc/testsuite/ada/acats/tests/cc/cc3605a.ada new file mode 100644 index 000000000..b9fb50b1b --- /dev/null +++ b/gcc/testsuite/ada/acats/tests/cc/cc3605a.ada @@ -0,0 +1,381 @@ +-- CC3605A.ADA + +-- Grant of Unlimited Rights +-- +-- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687, +-- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained +-- unlimited rights in the software and documentation contained herein. +-- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making +-- this public release, the Government intends to confer upon all +-- recipients unlimited rights equal to those held by the Government. +-- These rights include rights to use, duplicate, release or disclose the +-- released technical data and computer software in whole or in part, in +-- any manner and for any purpose whatsoever, and to have or permit others +-- to do so. +-- +-- DISCLAIMER +-- +-- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR +-- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED +-- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF 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 SOME DIFFERENCES BETWEEN THE FORMAL AND THE +-- ACTUAL SUBPROGRAMS DO NOT INVALIDATE A MATCH. +-- 1) CHECK DIFFERENT PARAMETER NAMES. +-- 2) CHECK DIFFERENT PARAMETER CONSTRAINTS. +-- 3) CHECK ONE PARAMETER CONSTRAINED AND THE OTHER +-- UNCONSTRAINED (WITH ARRAY, RECORD, ACCESS, AND +-- PRIVATE TYPES). +-- 4) CHECK PRESENCE OR ABSENCE OF AN EXPLICIT "IN" MODE +-- INDICATOR. +-- 5) DIFFERENT TYPE MARKS USED TO SPECIFY THE TYPE OF +-- PARAMETERS. + +-- HISTORY: +-- LDC 10/04/88 CREATED ORIGINAL TEST. + +PACKAGE CC3605A_PACK IS + + SUBTYPE INT IS INTEGER RANGE -100 .. 100; + + TYPE PRI_TYPE (SIZE : INT) IS PRIVATE; + + SUBTYPE PRI_CONST IS PRI_TYPE (2); + +PRIVATE + + TYPE ARR_TYPE IS ARRAY (INTEGER RANGE <>) OF BOOLEAN; + + TYPE PRI_TYPE (SIZE : INT) IS + RECORD + SUB_A : ARR_TYPE (1 .. SIZE); + END RECORD; + +END CC3605A_PACK; + + +WITH REPORT; +USE REPORT; +WITH CC3605A_PACK; +USE CC3605A_PACK; + +PROCEDURE CC3605A IS + + SUBTYPE ZERO_TO_TEN IS INTEGER + RANGE IDENT_INT (0) .. IDENT_INT (10); + + SUBTYPE ONE_TO_FIVE IS INTEGER + RANGE IDENT_INT (1) .. IDENT_INT (5); + + SUBPRG_ACT : BOOLEAN := FALSE; +BEGIN + TEST + ("CC3605A", "CHECK THAT SOME DIFFERENCES BETWEEN THE " & + "FORMAL AND THE ACTUAL PARAMETERS DO NOT " & + "INVALIDATE A MATCH"); + +---------------------------------------------------------------------- +-- DIFFERENT PARAMETER NAMES +---------------------------------------------------------------------- + + DECLARE + + PROCEDURE ACT_PROC (DIFF_NAME_PARM : ONE_TO_FIVE) IS + BEGIN + SUBPRG_ACT := TRUE; + END ACT_PROC; + + GENERIC + + WITH PROCEDURE PASSED_PROC (PARM : ONE_TO_FIVE); + + PROCEDURE GEN_PROC; + + PROCEDURE GEN_PROC IS + BEGIN + PASSED_PROC (ONE_TO_FIVE'FIRST); + END GEN_PROC; + + PROCEDURE INST_PROC IS NEW GEN_PROC (ACT_PROC); + BEGIN + INST_PROC; + IF NOT SUBPRG_ACT THEN + FAILED + ("DIFFERENT PARAMETER NAMES MADE MATCH INVALID"); + END IF; + END; + +---------------------------------------------------------------------- +-- DIFFERENT PARAMETER CONSTRAINTS +---------------------------------------------------------------------- + + DECLARE + + PROCEDURE ACT_PROC (PARM : ONE_TO_FIVE) IS + BEGIN + SUBPRG_ACT := TRUE; + END ACT_PROC; + + GENERIC + + WITH PROCEDURE PASSED_PROC (PARM : ZERO_TO_TEN); + + PROCEDURE GEN_PROC; + + PROCEDURE GEN_PROC IS + BEGIN + PASSED_PROC (ONE_TO_FIVE'FIRST); + END GEN_PROC; + + PROCEDURE INST_PROC IS NEW GEN_PROC (ACT_PROC); + BEGIN + SUBPRG_ACT := FALSE; + INST_PROC; + IF NOT SUBPRG_ACT THEN + FAILED + ("DIFFERENT PARAMETER CONSTRAINTS MADE MATCH " & + "INVALID"); + END IF; + END; + +---------------------------------------------------------------------- +-- ONE PARAMETER CONSTRAINED (ARRAY) +---------------------------------------------------------------------- + + DECLARE + + TYPE ARR_TYPE IS ARRAY (INTEGER RANGE <>) OF BOOLEAN; + + SUBTYPE ARR_CONST IS ARR_TYPE (ONE_TO_FIVE'FIRST .. + ONE_TO_FIVE'LAST); + + PASSED_PARM : ARR_CONST := (OTHERS => TRUE); + + PROCEDURE ACT_PROC (PARM : ARR_CONST) IS + BEGIN + SUBPRG_ACT := TRUE; + END ACT_PROC; + + GENERIC + + WITH PROCEDURE PASSED_PROC (PARM : ARR_TYPE); + + PROCEDURE GEN_PROC; + + PROCEDURE GEN_PROC IS + BEGIN + PASSED_PROC (PASSED_PARM); + END GEN_PROC; + + PROCEDURE INST_PROC IS NEW GEN_PROC (ACT_PROC); + BEGIN + SUBPRG_ACT := FALSE; + INST_PROC; + IF NOT SUBPRG_ACT THEN + FAILED + ("ONE ARRAY PARAMETER CONSTRAINED MADE MATCH " & + "INVALID"); + END IF; + END; + +---------------------------------------------------------------------- +-- ONE PARAMETER CONSTRAINED (RECORDS) +---------------------------------------------------------------------- + + DECLARE + + TYPE REC_TYPE (BOL : BOOLEAN) IS + RECORD + SUB_A : INTEGER; + CASE BOL IS + WHEN TRUE => + DSCR_A : INTEGER; + + WHEN FALSE => + DSCR_B : BOOLEAN; + + END CASE; + END RECORD; + + SUBTYPE REC_CONST IS REC_TYPE (TRUE); + + PASSED_PARM : REC_CONST := (TRUE, 1, 2); + + PROCEDURE ACT_PROC (PARM : REC_CONST) IS + BEGIN + SUBPRG_ACT := TRUE; + END ACT_PROC; + + GENERIC + + WITH PROCEDURE PASSED_PROC (PARM : REC_TYPE); + + PROCEDURE GEN_PROC; + + PROCEDURE GEN_PROC IS + BEGIN + PASSED_PROC (PASSED_PARM); + END GEN_PROC; + + PROCEDURE INST_PROC IS NEW GEN_PROC (ACT_PROC); + BEGIN + SUBPRG_ACT := FALSE; + INST_PROC; + IF NOT SUBPRG_ACT THEN + FAILED + ("ONE RECORD PARAMETER CONSTRAINED MADE MATCH " & + "INVALID"); + END IF; + END; + +---------------------------------------------------------------------- +-- ONE PARAMETER CONSTRAINED (ACCESS) +---------------------------------------------------------------------- + + DECLARE + + TYPE ARR_TYPE IS ARRAY (INTEGER RANGE <>) OF BOOLEAN; + + SUBTYPE ARR_CONST IS ARR_TYPE (ONE_TO_FIVE'FIRST .. + ONE_TO_FIVE'LAST); + + TYPE ARR_ACC_TYPE IS ACCESS ARR_TYPE; + + SUBTYPE ARR_ACC_CONST IS ARR_ACC_TYPE (1 .. 3); + + PASSED_PARM : ARR_ACC_TYPE := NULL; + + PROCEDURE ACT_PROC (PARM : ARR_ACC_CONST) IS + BEGIN + SUBPRG_ACT := TRUE; + END ACT_PROC; + + GENERIC + + WITH PROCEDURE PASSED_PROC (PARM : ARR_ACC_TYPE); + + PROCEDURE GEN_PROC; + + PROCEDURE GEN_PROC IS + BEGIN + PASSED_PROC (PASSED_PARM); + END GEN_PROC; + + PROCEDURE INST_PROC IS NEW GEN_PROC (ACT_PROC); + BEGIN + SUBPRG_ACT := FALSE; + INST_PROC; + IF NOT SUBPRG_ACT THEN + FAILED + ("ONE ACCESS PARAMETER CONSTRAINED MADE MATCH " & + "INVALID"); + END IF; + END; + +---------------------------------------------------------------------- +-- ONE PARAMETER CONSTRAINED (PRIVATE) +---------------------------------------------------------------------- + + DECLARE + PASSED_PARM : PRI_CONST; + + PROCEDURE ACT_PROC (PARM : PRI_CONST) IS + BEGIN + SUBPRG_ACT := TRUE; + END ACT_PROC; + + GENERIC + + WITH PROCEDURE PASSED_PROC (PARM : PRI_TYPE); + + PROCEDURE GEN_PROC; + + PROCEDURE GEN_PROC IS + BEGIN + PASSED_PROC (PASSED_PARM); + END GEN_PROC; + + PROCEDURE INST_PROC IS NEW GEN_PROC (ACT_PROC); + BEGIN + SUBPRG_ACT := FALSE; + INST_PROC; + IF NOT SUBPRG_ACT THEN + FAILED + ("ONE PRIVATE PARAMETER CONSTRAINED MADE MATCH " & + "INVALID"); + END IF; + END; + +---------------------------------------------------------------------- +-- PRESENCE (OR ABSENCE) OF AN EXPLICIT "IN" MODE +---------------------------------------------------------------------- + + DECLARE + + PROCEDURE ACT_PROC (PARM : INTEGER) IS + BEGIN + SUBPRG_ACT := TRUE; + END ACT_PROC; + + GENERIC + + WITH PROCEDURE PASSED_PROC (PARM : IN INTEGER); + + PROCEDURE GEN_PROC; + + PROCEDURE GEN_PROC IS + BEGIN + PASSED_PROC (1); + END GEN_PROC; + + PROCEDURE INST_PROC IS NEW GEN_PROC (ACT_PROC); + BEGIN + SUBPRG_ACT := FALSE; + INST_PROC; + IF NOT SUBPRG_ACT THEN + FAILED + ("PRESENCE OF AN EXPLICIT 'IN' MODE MADE MATCH " & + "INVALID"); + END IF; + END; + +---------------------------------------------------------------------- +-- DIFFERENT TYPE MARKS +---------------------------------------------------------------------- + + DECLARE + + SUBTYPE MARK_1_TYPE IS INTEGER; + + SUBTYPE MARK_2_TYPE IS INTEGER; + + PROCEDURE ACT_PROC (PARM1 : IN MARK_1_TYPE) IS + BEGIN + SUBPRG_ACT := TRUE; + END ACT_PROC; + + GENERIC + + WITH PROCEDURE PASSED_PROC (PARM2 : MARK_2_TYPE); + + PROCEDURE GEN_PROC; + + PROCEDURE GEN_PROC IS + BEGIN + PASSED_PROC (1); + END GEN_PROC; + + PROCEDURE INST_PROC IS NEW GEN_PROC (ACT_PROC); + BEGIN + SUBPRG_ACT := FALSE; + INST_PROC; + IF NOT SUBPRG_ACT THEN + FAILED ("DIFFERENT TYPE MARKS MADE MATCH INVALID"); + END IF; + END; + RESULT; +END CC3605A; diff --git a/gcc/testsuite/ada/acats/tests/cc/cc3606a.ada b/gcc/testsuite/ada/acats/tests/cc/cc3606a.ada new file mode 100644 index 000000000..4d63b7143 --- /dev/null +++ b/gcc/testsuite/ada/acats/tests/cc/cc3606a.ada @@ -0,0 +1,134 @@ +-- CC3606A.ADA + +-- Grant of Unlimited Rights +-- +-- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687, +-- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained +-- unlimited rights in the software and documentation contained herein. +-- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making +-- this public release, the Government intends to confer upon all +-- recipients unlimited rights equal to those held by the Government. +-- These rights include rights to use, duplicate, release or disclose the +-- released technical data and computer software in whole or in part, in +-- any manner and for any purpose whatsoever, and to have or permit others +-- to do so. +-- +-- DISCLAIMER +-- +-- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR +-- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED +-- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF 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 DEFAULT EXPRESSIONS OF A FORMAL SUBPROGRAM'S +-- FORMAL PARAMETERS ARE USED WHEN THE FORMAL SUBPROGRAM IS +-- CALLED IN THE INSTANTIATED UNIT (RATHER THAN ANY DEFAULT +-- ASSOCIATED WITH ACTUAL SUBPROGRAM'S PARAMETERS). + +-- HISTORY: +-- BCB 09/29/87 CREATED ORIGINAL TEST. + +WITH REPORT; USE REPORT; + +PROCEDURE CC3606A IS + + X : BOOLEAN; + Y : BOOLEAN; + + FUNCTION FUNC (A : INTEGER := 35) RETURN BOOLEAN IS + BEGIN + RETURN (A = 7); + END FUNC; + + PROCEDURE PROC (B : INTEGER := 35) IS + BEGIN + IF B /= 7 THEN + FAILED ("DEFAULT EXPRESSION OF FORMAL PARAMETER " & + "PROCEDURE NOT USED - 1"); + END IF; + END PROC; + + FUNCTION FUNC1 (C : INTEGER := 35) RETURN BOOLEAN IS + BEGIN + RETURN (C = 7); + END FUNC1; + + PROCEDURE PROC3 (D : INTEGER := 35) IS + BEGIN + IF D /= 7 THEN + FAILED ("DEFAULT EXPRESSION OF FORMAL PARAMETER " & + "PROCEDURE NOT USED - 2"); + END IF; + END PROC3; + + GENERIC + WITH FUNCTION FUNC (A : INTEGER := 7) RETURN BOOLEAN; + FUNCTION GENFUNC RETURN BOOLEAN; + + FUNCTION GENFUNC RETURN BOOLEAN IS + BEGIN + IF NOT FUNC THEN + FAILED ("DEFAULT EXPRESSION OF FORMAL PARAMETER " & + "FUNCTION NOT USED - 1"); + END IF; + RETURN TRUE; + END GENFUNC; + + GENERIC + WITH PROCEDURE PROC (B : INTEGER := 7); + PACKAGE PKG IS + END PKG; + + PACKAGE BODY PKG IS + BEGIN + PROC; + END PKG; + + GENERIC + WITH FUNCTION FUNC1 (C : INTEGER := 7) RETURN BOOLEAN; + PROCEDURE PROC2; + + PROCEDURE PROC2 IS + BEGIN + IF NOT FUNC1 THEN + FAILED ("DEFAULT EXPRESSION OF FORMAL PARAMETER " & + "FUNCTION NOT USED - 2"); + END IF; + END PROC2; + + GENERIC + WITH PROCEDURE PROC3 (D : INTEGER := 7) IS <>; + FUNCTION GENFUNC1 RETURN BOOLEAN; + + FUNCTION GENFUNC1 RETURN BOOLEAN IS + BEGIN + PROC3; + RETURN TRUE; + END GENFUNC1; + + FUNCTION NEWFUNC IS NEW GENFUNC(FUNC); + + PACKAGE PACK IS NEW PKG(PROC); + + PROCEDURE PROC4 IS NEW PROC2(FUNC1); + + FUNCTION NEWFUNC1 IS NEW GENFUNC1; + +BEGIN + + TEST ("CC3606A", "CHECK THAT THE DEFAULT EXPRESSIONS OF A " & + "FORMAL SUBPROGRAM'S FORMAL PARAMETERS ARE " & + "USED WHEN THE FORMAL SUBPROGRAM IS CALLED IN " & + "THE INSTANTIATED UNIT (RATHER THAN ANY " & + "DEFAULT ASSOCIATED WITH ACTUAL SUBPROGRAM'S " & + "PARAMETERS)"); + + X := NEWFUNC; + Y := NEWFUNC1; + PROC4; + + RESULT; +END CC3606A; diff --git a/gcc/testsuite/ada/acats/tests/cc/cc3606b.ada b/gcc/testsuite/ada/acats/tests/cc/cc3606b.ada new file mode 100644 index 000000000..79dc8a7ba --- /dev/null +++ b/gcc/testsuite/ada/acats/tests/cc/cc3606b.ada @@ -0,0 +1,134 @@ +-- CC3606B.ADA + +-- Grant of Unlimited Rights +-- +-- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687, +-- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained +-- unlimited rights in the software and documentation contained herein. +-- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making +-- this public release, the Government intends to confer upon all +-- recipients unlimited rights equal to those held by the Government. +-- These rights include rights to use, duplicate, release or disclose the +-- released technical data and computer software in whole or in part, in +-- any manner and for any purpose whatsoever, and to have or permit others +-- to do so. +-- +-- DISCLAIMER +-- +-- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR +-- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED +-- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF 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 CONSTRAINTS SPECIFIED FOR THE ACTUAL +-- SUBPROGRAM'S PARAMETERS ARE USED IN PLACE OF THOSE +-- ASSOCIATED WITH THE FORMAL SUBPROGRAM'S PARAMETERS +-- (INCLUDING PARAMETERS SPECIFIED WITH A FORMAL GENERIC TYPE). + +-- HISTORY: +-- LDC 06/30/88 CREATED ORIGINAL TEST. +-- PWN 05/31/96 Corrected spelling problems. + +WITH REPORT; USE REPORT; + +PROCEDURE CC3606B IS + + SUBTYPE ONE_TO_TEN IS + INTEGER RANGE IDENT_INT (1) .. IDENT_INT (10); + SUBTYPE ONE_TO_FIVE IS + INTEGER RANGE IDENT_INT (1) .. IDENT_INT (5); + +BEGIN + TEST ( "CC3606B", "CHECK THAT ANY CONSTRAINTS SPECIFIED FOR " & + "THE ACTUAL SUBPROGRAM'S PARAMETERS ARE USED " & + "IN PLACE OF THOSE ASSOCIATED WITH THE " & + "FORMAL SUBPROGRAM'S PARAMETERS (INCLUDING " & + "PARAMETERS SPECIFIED WITH A FORMAL GENERIC " & + "TYPE)"); + DECLARE + GENERIC + BRIAN : IN OUT INTEGER; + WITH PROCEDURE PASSED_PROC(LYNN :IN OUT ONE_TO_TEN); + PACKAGE GEN IS + END GEN; + + DOUG : INTEGER := 10; + + PACKAGE BODY GEN IS + BEGIN + PASSED_PROC(BRIAN); + FAILED("WRONG CONSTRAINTS FOR ACTUAL PARAMETER IN GEN"); + EXCEPTION + WHEN CONSTRAINT_ERROR => + NULL; + WHEN OTHERS => + FAILED("OTHER EXCEPTION WAS RAISED FOR ACTUAL " & + "PARAMETER"); + END GEN; + + PROCEDURE PROC(JODIE : IN OUT ONE_TO_FIVE) IS + JOHN : ONE_TO_TEN; + BEGIN + JOHN := IDENT_INT(JODIE); + EXCEPTION + WHEN OTHERS => + FAILED("EXCEPTION RAISED INSIDE PROCEDURE"); + END PROC; + + PACKAGE GEN_PCK IS NEW GEN( DOUG, PROC); + + BEGIN + NULL; + END; + DECLARE + TYPE ENUM IS (DAYTON, BEAVERCREEK, CENTERVILLE, ENGLEWOOD, + FAIRBORN, HUBER_HEIGHTS, KETTERING, MIAMISBURG, + OAKWOOD, RIVERSIDE, TROTWOOD, WEST_CARROLLTON, + VANDALIA); + SUBTYPE SUB_ENUM IS ENUM RANGE CENTERVILLE..FAIRBORN; + + GENERIC + TYPE T_TYPE IS (<>); + BRIAN : T_TYPE; + WITH FUNCTION PASSED_FUNC(LYNN : T_TYPE) + RETURN T_TYPE; + + PACKAGE GEN_TWO IS + END GEN_TWO; + + DOUG : ENUM := ENUM'FIRST; + + PACKAGE BODY GEN_TWO IS + + DAVE : T_TYPE; + + BEGIN + DAVE := PASSED_FUNC(BRIAN); + FAILED("WRONG CONSTRAINTS FOR ACTUAL PARAMETER IN " & + "GEN_TWO"); + EXCEPTION + WHEN CONSTRAINT_ERROR => + NULL; + WHEN OTHERS => + FAILED("OTHER EXCEPTION WAS " & + "RAISED FOR ACTUAL " & + "PARAMETER"); + END GEN_TWO; + + FUNCTION FUNC(JODIE : SUB_ENUM) RETURN SUB_ENUM IS + BEGIN + RETURN ENUM'VAL(IDENT_INT(ENUM'POS(JODIE))); + EXCEPTION + WHEN OTHERS => + FAILED("EXCEPTION RAISED INSIDE PROCEDURE"); + END FUNC; + + PACKAGE GEN_PCK_TWO IS NEW GEN_TWO( ENUM, DOUG, FUNC); + + BEGIN + RESULT; + END; +END CC3606B; diff --git a/gcc/testsuite/ada/acats/tests/cc/cc3607b.ada b/gcc/testsuite/ada/acats/tests/cc/cc3607b.ada new file mode 100644 index 000000000..701c739cf --- /dev/null +++ b/gcc/testsuite/ada/acats/tests/cc/cc3607b.ada @@ -0,0 +1,79 @@ +-- CC3607B.ADA + +-- Grant of Unlimited Rights +-- +-- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687, +-- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained +-- unlimited rights in the software and documentation contained herein. +-- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making +-- this public release, the Government intends to confer upon all +-- recipients unlimited rights equal to those held by the Government. +-- These rights include rights to use, duplicate, release or disclose the +-- released technical data and computer software in whole or in part, in +-- any manner and for any purpose whatsoever, and to have or permit others +-- to do so. +-- +-- DISCLAIMER +-- +-- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR +-- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED +-- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF 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 A DEFAULT SUBPROGRAM IS SPECIFIED WITH A BOX, A +-- SUBPROGRAM DIRECTLY VISIBLE AT THE POINT OF INSTANTIATION +-- IS USED. + +-- HISTORY: +-- LDC 08/23/88 CREATED ORIGINAL TEST. + +WITH REPORT; USE REPORT; +PROCEDURE CC3607B IS + +BEGIN + TEST ("CC3607B", "CHECK THAT WHEN A DEFAULT SUBPROGRAM IS " & + "SPECIFIED WITH A BOX, A SUBPROGRAM DIRECTLY " & + "VISIBLE AT THE POINT OF INSTANTIATION IS USED"); + DECLARE + PACKAGE PROC_PACK IS + PROCEDURE PROC; + + GENERIC + WITH PROCEDURE PROC IS <>; + PACKAGE GEN_PACK IS + PROCEDURE DO_PROC; + END GEN_PACK; + END PROC_PACK; + USE PROC_PACK; + + PACKAGE BODY PROC_PACK IS + PROCEDURE PROC IS + BEGIN + FAILED("WRONG SUBPROGRAM WAS USED"); + END PROC; + + PACKAGE BODY GEN_PACK IS + PROCEDURE DO_PROC IS + BEGIN + PROC; + END DO_PROC; + END GEN_PACK; + END PROC_PACK; + + PROCEDURE PROC IS + BEGIN + COMMENT ("SUBPROGRAM VISIBLE AT INSTANTIATION WAS " & + "USED"); + END PROC; + + PACKAGE NEW_PACK IS NEW GEN_PACK; + + BEGIN + NEW_PACK.DO_PROC; + END; + + RESULT; +END CC3607B; diff --git a/gcc/testsuite/ada/acats/tests/cc/cc40001.a b/gcc/testsuite/ada/acats/tests/cc/cc40001.a new file mode 100644 index 000000000..bf42470e6 --- /dev/null +++ b/gcc/testsuite/ada/acats/tests/cc/cc40001.a @@ -0,0 +1,403 @@ +-- CC40001.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 adjust is called on the value of a constant object created +-- by the evaluation of a generic association for a formal object of +-- mode in. +-- +-- Check that those values are also subsequently finalized. +-- +-- TEST DESCRIPTION: +-- Create a backdrop of a controlled type sufficient to check that the +-- correct operations get called at appropriate times. Create a generic +-- unit that takes a formal parameter of a formal type. Create instances +-- of this generic using various "levels" of the controlled type. Check +-- the same case for a generic child unit. +-- +-- The cases tested are where the type of the formal object is: +-- a visible classwide type : CC40001_2 +-- a formal private type : CC40001_3 +-- a formal tagged type : CC40001_4 +-- +-- To more fully take advantage of the features of the language, and +-- present a test which is "user oriented" this test utilizes multiple +-- aspects of the language in combination. Using Ada.Strings.Unbounded +-- in combination with Ada.Finalization and Ada.Calendar to build layers +-- of an object oriented system will likely be very common in actual +-- practice. A common paradigm in the language will also be the use of +-- a parent package defining "basic" tagged types, and child packages +-- will expand on those types via derivation. The model used in this +-- test is a simple type containing a character identity (used in the +-- identity). The next level of type add a timestamp. Further levels +-- might add location information, etc. however for the purposes of this +-- test we stop at the second layer, as it is sufficient to test the +-- stated objective. +-- +-- +-- CHANGE HISTORY: +-- 06 FEB 96 SAIC Initial version +-- 30 APR 96 SAIC Added finalization checks for 2.1 +-- 13 FEB 97 PWB.CTA Moved global objects into bodies, after Initialize +-- body is elaborated; counted finalizations correctly. +--! + +----------------------------------------------------------------- CC40001_0 + +with Ada.Finalization; +with Ada.Strings.Unbounded; +package CC40001_0 is + + type States is ( Erroneous, Defaulted, Initialized, Reset, Adjusted ); + + type Simple_Object(ID: Character) is + new Ada.Finalization.Controlled with + record + TC_Current_State : States := Defaulted; + Name : Ada.Strings.Unbounded.Unbounded_String; + end record; + + procedure User_Operation( COB: in out Simple_Object; Name : String ); + procedure Initialize( COB: in out Simple_Object ); + procedure Adjust ( COB: in out Simple_Object ); + procedure Finalize ( COB: in out Simple_Object ); + + Finalization_Count : Natural; + +end CC40001_0; + +-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- + +with Report; +with TCTouch; +package body CC40001_0 is + + procedure User_Operation( COB: in out Simple_Object; Name : String ) is + begin + COB.Name := Ada.Strings.Unbounded.To_Unbounded_String(Name); + end User_Operation; + + procedure Initialize( COB: in out Simple_Object ) is + begin + COB.TC_Current_State := Initialized; + end Initialize; + + procedure Adjust ( COB: in out Simple_Object ) is + begin + COB.TC_Current_State := Adjusted; + TCTouch.Touch('A'); -------------------------------------------------- A + TCTouch.Touch(COB.ID); ------------------------------------------------ ID + -- note that the calls to touch will not be directly validated, it is + -- expected that some number > 0 of calls will be made to this procedure, + -- the subtests then clear (Flush) the Touch buffer and perform actions + -- where an incorrect implementation might call this procedure. Such a + -- call will fail on the attempt to "Validate" the null string. + end Adjust; + + procedure Finalize ( COB: in out Simple_Object ) is + begin + COB.TC_Current_State := Erroneous; + Finalization_Count := Finalization_Count +1; + end Finalize; + + TC_Global_Object : Simple_Object('G'); + +end CC40001_0; + +----------------------------------------------------------------- CC40001_1 + +with Ada.Calendar; +package CC40001_0.CC40001_1 is + + type Object_In_Time(ID: Character) is + new Simple_Object(ID) with + record + Birth : Ada.Calendar.Time; + Activity : Ada.Calendar.Time; + end record; + + procedure User_Operation( COB: in out Object_In_Time; + Name: String ); + + procedure Initialize( COB: in out Object_In_Time ); + procedure Adjust ( COB: in out Object_In_Time ); + procedure Finalize ( COB: in out Object_In_Time ); + +end CC40001_0.CC40001_1; + +-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- + +with Report; +with TCTouch; +package body CC40001_0.CC40001_1 is + + procedure Initialize( COB: in out Object_In_Time ) is + begin + COB.TC_Current_State := Initialized; + COB.Birth := Ada.Calendar.Clock; + end Initialize; + + procedure Adjust ( COB: in out Object_In_Time ) is + begin + COB.TC_Current_State := Adjusted; + TCTouch.Touch('a'); ------------------------------------------------ a + TCTouch.Touch(COB.ID); ------------------------------------------------ ID + end Adjust; + + procedure Finalize ( COB: in out Object_In_Time ) is + begin + COB.TC_Current_State := Erroneous; + Finalization_Count := Finalization_Count +1; + end Finalize; + + procedure User_Operation( COB: in out Object_In_Time; + Name: String ) is + begin + CC40001_0.User_Operation( Simple_Object(COB), Name ); + COB.Activity := Ada.Calendar.Clock; + COB.TC_Current_State := Reset; + end User_Operation; + + TC_Time_Object : Object_In_Time('g'); + +end CC40001_0.CC40001_1; + +----------------------------------------------------------------- CC40001_2 + +generic + TC_Check_Object : in CC40001_0.Simple_Object'Class; +package CC40001_0.CC40001_2 is + procedure TC_Verify_State; +end CC40001_0.CC40001_2; + +-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- + +with Report; +package body CC40001_0.CC40001_2 is + + procedure TC_Verify_State is + begin + if TC_Check_Object.TC_Current_State /= Adjusted then + Report.Failed( "CC40001_2 : Formal Object not adjusted" ); + end if; + end TC_Verify_State; + +end CC40001_0.CC40001_2; + +----------------------------------------------------------------- CC40001_3 + +generic + type Formal_Private(<>) is private; + TC_Check_Object : in Formal_Private; + with function Bad_Status( O: Formal_Private ) return Boolean; +package CC40001_0.CC40001_3 is + procedure TC_Verify_State; +end CC40001_0.CC40001_3; + +-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- + +with Report; +package body CC40001_0.CC40001_3 is + + procedure TC_Verify_State is + begin + if Bad_Status( TC_Check_Object ) then + Report.Failed( "CC40001_3 : Formal Object not adjusted" ); + end if; + end TC_Verify_State; + +end CC40001_0.CC40001_3; + +----------------------------------------------------------------- CC40001_4 + +generic + type Formal_Tagged_Private(<>) is tagged private; + TC_Check_Object : in Formal_Tagged_Private; + with function Bad_Status( O: Formal_Tagged_Private ) return Boolean; +package CC40001_0.CC40001_4 is + procedure TC_Verify_State; +end CC40001_0.CC40001_4; + +-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- + +with Report; +package body CC40001_0.CC40001_4 is + + procedure TC_Verify_State is + begin + if Bad_Status( TC_Check_Object ) then + Report.Failed( "CC40001_4 : Formal Object not adjusted" ); + end if; + end TC_Verify_State; + +end CC40001_0.CC40001_4; + +------------------------------------------------------------------- CC40001 + +with Report; +with TCTouch; +with CC40001_0.CC40001_1; +with CC40001_0.CC40001_2; +with CC40001_0.CC40001_3; +with CC40001_0.CC40001_4; +procedure CC40001 is + + function Not_Adjusted( CO : CC40001_0.Simple_Object ) + return Boolean is + use type CC40001_0.States; + begin + return CO.TC_Current_State /= CC40001_0.Adjusted; + end Not_Adjusted; + + function Not_Adjusted( CO : CC40001_0.CC40001_1.Object_In_Time ) + return Boolean is + use type CC40001_0.States; + begin + return CO.TC_Current_State /= CC40001_0.Adjusted; + end Not_Adjusted; + + -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- Subtest 1 + + procedure Subtest_1 is + Object_0 : CC40001_0.Simple_Object('T'); + Object_1 : CC40001_0.CC40001_1.Object_In_Time('t'); + + package Subtest_1_1 is + new CC40001_0.CC40001_2( Object_0 ); -- classwide generic formal object + + package Subtest_1_2 is + new CC40001_0.CC40001_2( Object_1 ); -- classwide generic formal object + begin + TCTouch.Flush; -- clear out all "A" and "T" entries, no further calls + -- to Touch should occur before the call to Validate + + -- set the objects TC_Current_State to "Reset" + CC40001_0.User_Operation( Object_0, "Subtest 1" ); + CC40001_0.CC40001_1.User_Operation( Object_1, "Subtest 1" ); + + -- check that the objects TC_Current_State is "Adjusted" + Subtest_1_1.TC_Verify_State; + Subtest_1_2.TC_Verify_State; + + TCTouch.Validate( "", "No actions should occur here, subtest 1" ); + + end Subtest_1; + + -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- Subtest 2 + + procedure Subtest_2 is + Object_0 : CC40001_0.Simple_Object('T'); + Object_1 : CC40001_0.CC40001_1.Object_In_Time('t'); + + package Subtest_2_1 is -- generic formal object is discriminated private + new CC40001_0.CC40001_3( CC40001_0.Simple_Object, + Object_0, + Not_Adjusted ); + + package Subtest_2_2 is -- generic formal object is discriminated private + new CC40001_0.CC40001_3( CC40001_0.CC40001_1.Object_In_Time, + Object_1, + Not_Adjusted ); + + begin + TCTouch.Flush; -- clear out all "A" and "T" entries + + -- set the objects state to "Reset" + CC40001_0.User_Operation( Object_0, "Subtest 2" ); + CC40001_0.CC40001_1.User_Operation( Object_1, "Subtest 2" ); + + Subtest_2_1.TC_Verify_State; + Subtest_2_2.TC_Verify_State; + + TCTouch.Validate( "", "No actions should occur here, subtest 2" ); + + end Subtest_2; + + -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- Subtest 3 + + procedure Subtest_3 is + Object_0 : CC40001_0.Simple_Object('T'); + Object_1 : CC40001_0.CC40001_1.Object_In_Time('t'); + + package Subtest_3_1 is -- generic formal object is discriminated tagged + new CC40001_0.CC40001_4( CC40001_0.Simple_Object, + Object_0, + Not_Adjusted ); + + package Subtest_3_2 is -- generic formal object is discriminated tagged + new CC40001_0.CC40001_4( CC40001_0.CC40001_1.Object_In_Time, + Object_1, + Not_Adjusted ); + begin + TCTouch.Flush; -- clear out all "A" and "T" entries + + -- set the objects state to "Reset" + CC40001_0.User_Operation( Object_0, "Subtest 3" ); + CC40001_0.CC40001_1.User_Operation( Object_1, "Subtest 3" ); + + Subtest_3_1.TC_Verify_State; + Subtest_3_2.TC_Verify_State; + + TCTouch.Validate( "", "No actions should occur here, subtest 3" ); + + end Subtest_3; + +begin -- Main test procedure. + + Report.Test ("CC40001", "Check that adjust and finalize are called on " & + "the constant object created by the " & + "evaluation of a generic association for a " & + "formal object of mode in" ); + + -- check that the created constant objects are properly adjusted + -- and subsequently finalized + + CC40001_0.Finalization_Count := 0; + + Subtest_1; + + if CC40001_0.Finalization_Count < 4 then + Report.Failed("Insufficient Finalizations for Subtest 1"); + end if; + + CC40001_0.Finalization_Count := 0; + + Subtest_2; + + if CC40001_0.Finalization_Count < 4 then + Report.Failed("Insufficient Finalizations for Subtest 2"); + end if; + + CC40001_0.Finalization_Count := 0; + + Subtest_3; + + if CC40001_0.Finalization_Count < 4 then + Report.Failed("Insufficient Finalizations for Subtest 3"); + end if; + + Report.Result; + +end CC40001; diff --git a/gcc/testsuite/ada/acats/tests/cc/cc50001.a b/gcc/testsuite/ada/acats/tests/cc/cc50001.a new file mode 100644 index 000000000..32a1afeb3 --- /dev/null +++ b/gcc/testsuite/ada/acats/tests/cc/cc50001.a @@ -0,0 +1,257 @@ +-- CC50001.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, in an instance, each implicit declaration of a predefined +-- operator of a formal tagged private type declares a view of the +-- corresponding predefined operator of the actual type (even if the +-- operator has been overridden for the actual type). Check that the +-- body executed is determined by the type and tag of the operands. +-- +-- TEST DESCRIPTION: +-- The formal tagged private type has an unknown discriminant part, and +-- is thus indefinite. This allows both definite and indefinite types +-- to be passed as actuals. For tagged types, definite implies +-- nondiscriminated, and indefinite implies discriminated (with known +-- or unknown discriminants). +-- +-- Only nonlimited tagged types are tested, since equality operators +-- are not predefined for limited types. +-- +-- A tagged type is passed as an actual to a generic formal tagged +-- private type. The tagged type overrides the predefined equality +-- operator. A subprogram within the generic calls the equality operator +-- of the formal type. In an instance, the equality operator denotes +-- a view of the predefined operator of the actual type, but the +-- call dispatches to the body of the overriding operator. +-- +-- +-- CHANGE HISTORY: +-- 06 Dec 94 SAIC ACVC 2.0 +-- 21 Nov 95 SAIC ACVC 2.0.1 fixes: Corrected expected result on +-- calls to "=" within the instance. Modified +-- commentary. +-- +--! + +package CC50001_0 is + + type Count_Type is tagged record -- Nondiscriminated + Count : Integer := 0; -- tagged type. + end record; + + function "="(Left, Right : Count_Type) -- User-defined + return Boolean; -- equality operator. + + + subtype Str_Len is Natural range 0 .. 100; + subtype Stu_ID is String (1 .. 5); + subtype Dept_ID is String (1 .. 4); + subtype Emp_ID is String (1 .. 9); + type Status is (Student, Faculty, Staff); + + type Person_Type (Stat : Status; -- Discriminated + NameLen, AddrLen : Str_Len) is -- tagged type. + tagged record + Name : String (1 .. NameLen); + Address : String (1 .. AddrLen); + case Stat is + when Student => + Student_ID : Stu_ID; + when Faculty => + Department : Dept_ID; + when Staff => + Employee_ID : Emp_ID; + end case; + end record; + + function "="(Left, Right : Person_Type) -- User-defined + return Boolean; -- equality operator. + + + -- Testing entities: ------------------------------------------------ + + TC_Count_Item : constant Count_Type := (Count => 111); + + TC_Person_Item : constant Person_Type := + (Faculty, 18, 17, "Eccles, John Scott", "Popham House, Lee", "0931"); + + --------------------------------------------------------------------- + + +end CC50001_0; + + + --===================================================================-- + + +package body CC50001_0 is + + function "="(Left, Right : Count_Type) return Boolean is + begin + return False; -- Return FALSE even if Left = Right. + end "="; + + + function "="(Left, Right : Person_Type) return Boolean is + begin + return False; -- Return FALSE even if Left = Right. + end "="; + +end CC50001_0; + + + --===================================================================-- + + +with CC50001_0; -- Tagged (actual) type declarations. +generic -- Generic stack abstraction. + + type Item (<>) is tagged private; -- Formal tagged private type. + +package CC50001_1 is + + -- Simulate a generic stack abstraction. In a real application, the + -- second operand of Push might be of type Stack, and type Stack + -- would have at least one component (pointing to the top stack item). + + type Stack is private; + + procedure Push (I : in Item; TC_Check : out Boolean); + + -- ... Other stack operations. + +private + + -- ... Stack and ancillary type declarations. + + type Stack is record -- Artificial. + null; + end record; + +end CC50001_1; + + + --===================================================================-- + + +package body CC50001_1 is + + -- For the sake of brevity, the implementation of Push is completely + -- artificial; the goal is to model a call of the equality operator within + -- the generic. + -- + -- A real application might implement Push such that it does not add new + -- items to the stack if they are identical to the top item; in that + -- case, the equality operator would be called as part of an "if" + -- condition. + + procedure Push (I : in Item; TC_Check : out Boolean) is + begin + TC_Check := not (I = I); -- Call user-defined "="; should + -- return FALSE. Negation of + -- result makes TC_Check TRUE. + end Push; + +end CC50001_1; + + + --==================================================================-- + + +with CC50001_0; -- Tagged (actual) type declarations. +with CC50001_1; -- Generic stack abstraction. + +use CC50001_0; -- Overloaded "=" directly visible. + +with Report; +procedure CC50001 is + + package Count_Stacks is new CC50001_1 (CC50001_0.Count_Type); + package Person_Stacks is new CC50001_1 (CC50001_0.Person_Type); + + User_Defined_Op_Called : Boolean; + +begin + Report.Test ("CC50001", "Check that, in an instance, each implicit " & + "declaration of a primitive subprogram of a formal tagged " & + "private type declares a view of the corresponding " & + "predefined operator of the actual type (even if the " & + "operator has been overridden or hidden for the actual type)"); + +-- +-- Test which "=" is called inside generic: +-- + + User_Defined_Op_Called := False; + + Count_Stacks.Push (CC50001_0.TC_Count_Item, + User_Defined_Op_Called); + + + if not User_Defined_Op_Called then + Report.Failed ("User-defined ""="" not called inside generic for Count"); + end if; + + + User_Defined_Op_Called := False; + + Person_Stacks.Push (CC50001_0.TC_Person_Item, + User_Defined_Op_Called); + + if not User_Defined_Op_Called then + Report.Failed ("User-defined ""="" not called inside generic " & + "for Person"); + end if; + + +-- +-- Test which "=" is called outside generic: +-- + + User_Defined_Op_Called := False; + + User_Defined_Op_Called := + not (CC50001_0.TC_Count_Item = CC50001_0.TC_Count_Item); + + if not User_Defined_Op_Called then + Report.Failed ("User-defined ""="" not called outside generic "& + "for Count"); + end if; + + + User_Defined_Op_Called := False; + + User_Defined_Op_Called := + not (CC50001_0.TC_Person_Item = CC50001_0.TC_Person_Item); + + if not User_Defined_Op_Called then + Report.Failed ("User-defined ""="" not called outside generic "& + "for Person"); + end if; + + + Report.Result; +end CC50001; diff --git a/gcc/testsuite/ada/acats/tests/cc/cc50a01.a b/gcc/testsuite/ada/acats/tests/cc/cc50a01.a new file mode 100644 index 000000000..4d5dfdfd5 --- /dev/null +++ b/gcc/testsuite/ada/acats/tests/cc/cc50a01.a @@ -0,0 +1,313 @@ +-- CC50A01.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 formal parameter of a library-level generic unit may be +-- a formal tagged private type. Check that a nonlimited tagged type may +-- be passed as an actual. Check that if the formal type is indefinite, +-- both indefinite and definite types may be passed as actuals. +-- +-- TEST DESCRIPTION: +-- The generic package declares a formal tagged private type (this can +-- be considered the parent "mixin" class). This type is extended in +-- the generic to provide support for stacks of items of any nonlimited +-- tagged type. Stacks are modeled as singly linked lists, with the list +-- nodes being objects of the extended type. +-- +-- A generic testing procedure pushes items onto a stack, and pops them +-- back off, verifying the state of the stack at various points along the +-- way. The push and pop routines exercise functionality important to +-- tagged types, such as type conversion toward the root of the derivation +-- class and extension aggregates. +-- +-- The formal tagged private type has an unknown discriminant part, and +-- is thus indefinite. This allows both definite and indefinite types +-- to be passed as actuals. For tagged types, definite implies +-- nondiscriminated, and indefinite implies discriminated (with known +-- or unknown discriminants). +-- +-- TEST FILES: +-- This test consists of the following files: +-- +-- FC50A00.A +-- -> CC50A01.A +-- +-- +-- CHANGE HISTORY: +-- 06 Dec 94 SAIC ACVC 2.0 +-- 21 Nov 95 SAIC ACVC 2.0.1 fixes: Moved instantiations of +-- BC50A01_0 to library level. +-- 11 Aug 96 SAIC ACVC 2.1: Updated prologue. Added pragma +-- Elaborate to context clauses for CC50A01_2 & _3. +-- +--! + +with FC50A00; -- Tagged (actual) type declarations. +generic -- Generic stack abstraction. + + type Item (<>) is tagged private; -- Formal tagged private type. + TC_Default_Value : Item; -- Needed in View_Top (see + -- below). +package CC50A01_0 is + + type Stack is private; + +-- Note that because the actual type corresponding to Item may be +-- unconstrained, the functions of removing the top item from the stack and +-- returning the value of the top item of the stack have been separated into +-- Pop and View_Top, respectively. This is necessary because otherwise the +-- returned value would have to be an out parameter of Pop, which would +-- require the user (in the unconstrained case) to create an uninitialized +-- unconstrained object to serve as the actual, which is illegal. + + procedure Push (I : in Item; S : in out Stack); + procedure Pop (S : in out Stack); + function View_Top (S : Stack) return Item; + + function Size_Of (S : Stack) return Natural; + +private + + type Stack_Item; + type Stack_Ptr is access Stack_Item; + + type Stack_Item is new Item with record -- Extends formal type. + Next : Stack_Ptr := null; + end record; + + type Stack is record + Top : Stack_Ptr := null; + Size : Natural := 0; + end record; + +end CC50A01_0; + + + --==================================================================-- + + +package body CC50A01_0 is + + -- Link NewItem in at the top of the stack (the extension aggregate within + -- the allocator initializes the inherited portion of NewItem to equal I, + -- and NewItem.Next to point to what S.Top points to). + + procedure Push (I : in Item; S : in out Stack) is + NewItem : Stack_Ptr; + begin + NewItem := new Stack_Item'(I with S.Top); -- Extension aggregate. + S.Top := NewItem; + S.Size := S.Size + 1; + end Push; + + + -- Remove item from top of stack. This procedure only updates the state of + -- the stack; it does not return the value of the popped item. Hence, in + -- order to accomplish a "true" pop, both View_Top and Pop must be called + -- consecutively. + -- + -- If the stack is empty, the Pop is ignored (for simplicity; in a true + -- application this might be treated as an error condition). + + procedure Pop (S : in out Stack) is + begin + if S.Top = null then -- Stack is empty. + null; + -- Raise exception. + else + S.Top := S.Top.Next; + S.Size := S.Size - 1; + -- Deallocate discarded node. + end if; + end Pop; + + + -- Return the value of the top item on the stack. This procedure only + -- returns the value; it does not remove the top item from the stack. + -- Hence, in order to accomplish a "true" pop, both View_Top and Pop must + -- be called consecutively. + -- + -- Since items on the stack are of a type (Stack_Item) derived from Item, + -- which is a (tagged) private type, type conversion toward the root is the + -- only way to get a value of type Item for return to the caller. + -- + -- If the stack is empty, View_Top returns a pre-specified default value. + -- (In a true application, an exception might be raised instead). + + function View_Top (S : Stack) return Item is + begin + if S.Top = null then -- Stack is empty. + return TC_Default_Value; -- Testing artifice. + -- Raise exception. + else + return Item(S.Top.all); -- Type conversion. + end if; + end View_Top; + + + function Size_Of (S : Stack) return Natural is + begin + return (S.Size); + end Size_Of; + + +end CC50A01_0; + + + --==================================================================-- + + +-- The formal package Stacker below is needed to gain access to the +-- appropriate version of the "generic" type Stack. It is provided with an +-- explicit actual part in order to restrict the packages that can be passed +-- as actuals to those which have been instantiated with the same actuals +-- which this generic procedure has been instantiated with. + +with CC50A01_0; -- Generic stack abstraction. +generic + type Item_Type (<>) is tagged private; -- Formal tagged private type. + Default : Item_Type; + with package Stacker is new CC50A01_0 (Item_Type, Default); +procedure CC50A01_1 (S : in out Stacker.Stack; I : in Item_Type); + + + --==================================================================-- + +-- +-- This generic procedure performs all of the testing of the +-- stack abstraction. +-- + +with Report; +procedure CC50A01_1 (S : in out Stacker.Stack; I : in Item_Type) is +begin + Stacker.Push (I, S); -- Push onto empty stack. + Stacker.Push (I, S); -- Push onto nonempty stack. + + if Stacker.Size_Of (S) /= 2 then + Report.Failed (" Wrong stack size after 2 Pushes"); + end if; + + -- Calls to View_Top must initialize a declared object of type Item_Type + -- because the type may be unconstrained. + + declare + Buffer1 : Item_Type := Stacker.View_Top (S); + begin + Stacker.Pop (S); -- Pop item off nonempty stack. + if Buffer1 /= I then + Report.Failed (" Wrong stack item value after 1st Pop"); + end if; + end; + + declare + Buffer2 : Item_Type := Stacker.View_Top (S); + begin + Stacker.Pop (S); -- Pop last item off stack. + if Buffer2 /= I then + Report.Failed (" Wrong stack item value after 2nd Pop"); + end if; + end; + + if Stacker.Size_Of (S) /= 0 then + Report.Failed (" Wrong stack size after 2 Pops"); + end if; + + declare + Buffer3 : Item_Type := Stacker.View_Top (S); + begin + if Buffer3 /= Default then + Report.Failed (" Wrong result after Pop of empty stack"); + end if; + Stacker.Pop (S); -- Pop off empty stack. + end; + +end CC50A01_1; + + + --==================================================================-- + + +with FC50A00; + +with CC50A01_0; +pragma Elaborate (CC50A01_0); + +package CC50A01_2 is new CC50A01_0 (FC50A00.Count_Type, + FC50A00.TC_Default_Count); + + + --==================================================================-- + + +with FC50A00; + +with CC50A01_0; +pragma Elaborate (CC50A01_0); + +package CC50A01_3 is new CC50A01_0 (FC50A00.Person_Type, + FC50A00.TC_Default_Person); + + + --==================================================================-- + + +with FC50A00; -- Tagged (actual) type declarations. +with CC50A01_0; -- Generic stack abstraction. +with CC50A01_1; -- Generic stack testing procedure. +with CC50A01_2; +with CC50A01_3; + +with Report; +procedure CC50A01 is + + package Count_Stacks renames CC50A01_2; + package Person_Stacks renames CC50A01_3; + + + procedure TC_Count_Test is new CC50A01_1 (FC50A00.Count_Type, + FC50A00.TC_Default_Count, + Count_Stacks); + Count_Stack : Count_Stacks.Stack; + + + procedure TC_Person_Test is new CC50A01_1 (FC50A00.Person_Type, + FC50A00.TC_Default_Person, + Person_Stacks); + Person_Stack : Person_Stacks.Stack; + +begin + Report.Test ("CC50A01", "Check that a formal parameter of a " & + "library-level generic unit may be a formal tagged " & + "private type"); + + Report.Comment ("Testing definite tagged type.."); + TC_Count_Test (Count_Stack, FC50A00.TC_Count_Item); + + Report.Comment ("Testing indefinite tagged type.."); + TC_Person_Test (Person_Stack, FC50A00.TC_Person_Item); + + Report.Result; +end CC50A01; diff --git a/gcc/testsuite/ada/acats/tests/cc/cc50a02.a b/gcc/testsuite/ada/acats/tests/cc/cc50a02.a new file mode 100644 index 000000000..6c2bf5fb0 --- /dev/null +++ b/gcc/testsuite/ada/acats/tests/cc/cc50a02.a @@ -0,0 +1,227 @@ +-- CC50A02.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 nonlimited tagged type may be passed as an actual to a +-- formal (non-tagged) private type. Check that if the formal type has +-- an unknown discriminant part, a class-wide type may also be passed as +-- an actual. +-- +-- TEST DESCRIPTION: +-- A generic package declares a formal private type and defines a +-- stack abstraction. Stacks are modeled as singly linked lists of +-- pointers to elements. Pointers are used because the elements may +-- be unconstrained. +-- +-- A generic testing procedure pushes an item onto a stack, then views +-- the item on top of the stack. +-- +-- The formal private type has an unknown discriminant part, and +-- is thus indefinite. This allows both definite and indefinite types +-- (including class-wide types) to be passed as actuals. For tagged types, +-- definite implies nondiscriminated, and indefinite implies discriminated +-- (with known/unknown discriminants). +-- +-- TEST FILES: +-- The following files comprise this test: +-- +-- FC50A00.A +-- -> CC50A02.A +-- +-- +-- CHANGE HISTORY: +-- 06 Dec 94 SAIC ACVC 2.0 +-- 10 Nov 95 SAIC ACVC 2.0.1 fixes: Removed use of formal package +-- exception name in exception choice. +-- +--! + +generic -- Generic stack abstraction. + type Item (<>) is private; -- Formal private type. +package CC50A02_0 is + + type Stack is private; + + procedure Push (I : in Item; S : in out Stack); + function View_Top (S : Stack) return Item; + + -- ...Other stack operations... + + Stack_Empty : exception; + +private + + type Item_Ptr is access Item; + + type Stack_Item; + type Stack_Ptr is access Stack_Item; + + type Stack_Item is record + Item : Item_Ptr; + Next : Stack_Ptr; + end record; + + type Stack is record + Top : Stack_Ptr := null; + Size : Natural := 0; + end record; + +end CC50A02_0; + + + --==================================================================-- + + +package body CC50A02_0 is + + -- Link NewItem in at the top of the stack. + + procedure Push (I : in Item; S : in out Stack) is + NewItem : Item_Ptr := new Item'(I); + Element : Stack_Ptr := new Stack_Item'(Item => NewItem, Next => S.Top); + begin + S.Top := Element; + S.Size := S.Size + 1; + end Push; + + + -- Return (copy) of top item on stack. Do NOT remove from stack. + + function View_Top (S : Stack) return Item is + begin + if S.Top = null then + raise Stack_Empty; + else + return S.Top.Item.all; + end if; + end View_Top; + +end CC50A02_0; + + + --==================================================================-- + + +-- The formal package Stacker below is needed to gain access to the +-- appropriate version of the "generic" type Stack. It is provided with an +-- explicit actual part in order to restrict the packages that can be passed +-- as actuals to those which have been instantiated with the same actuals +-- which this generic procedure has been instantiated with. + +with CC50A02_0; -- Generic stack abstraction. +generic + type Item_Type (<>) is private; -- Formal private type. + with package Stacker is new CC50A02_0 (Item_Type); +procedure CC50A02_1 (S : in out Stacker.Stack; I : in Item_Type); + + + --==================================================================-- + +-- +-- This generic procedure performs all of the testing of the +-- stack abstraction. +-- + +with Report; +procedure CC50A02_1 (S : in out Stacker.Stack; I : in Item_Type) is +begin + Stacker.Push (I, S); -- Push onto empty stack. + + -- Calls to View_Top must initialize a declared object of type Item_Type + -- because the type may be unconstrained. + + declare + Buffer : Item_Type := Stacker.View_Top (S); + begin + if Buffer /= I then + Report.Failed (" Expected item not on stack"); + end if; + exception + when Constraint_Error => + Report.Failed (" Unexpected error: Tags of pushed and popped " & + "items don't match"); + end; + + +exception + when others => + Report.Failed (" Unexpected error: Item not pushed onto stack"); +end CC50A02_1; + + + --==================================================================-- + + +with FC50A00; -- Tagged (actual) type declarations. +with CC50A02_0; -- Generic stack abstraction. +with CC50A02_1; -- Generic stack testing procedure. + +with Report; +procedure CC50A02 is + + -- + -- Pass a nondiscriminated tagged actual: + -- + + package Count_Stacks is new CC50A02_0 (FC50A00.Count_Type); + procedure TC_Count_Test is new CC50A02_1 (FC50A00.Count_Type, + Count_Stacks); + Count_Stack : Count_Stacks.Stack; + + + -- + -- Pass a discriminated tagged actual: + -- + + package Person_Stacks is new CC50A02_0 (FC50A00.Person_Type); + procedure TC_Person_Test is new CC50A02_1 (FC50A00.Person_Type, + Person_Stacks); + Person_Stack : Person_Stacks.Stack; + + + -- + -- Pass a class-wide actual: + -- + + package People_Stacks is new CC50A02_0 (FC50A00.Person_Type'Class); + procedure TC_People_Test is new CC50A02_1 (FC50A00.Person_Type'Class, + People_Stacks); + People_Stack : People_Stacks.Stack; + +begin + Report.Test ("CC50A02", "Check that tagged actuals may be passed " & + "to a formal (nontagged) private type"); + + Report.Comment ("Testing definite tagged type.."); + TC_Count_Test (Count_Stack, FC50A00.TC_Count_Item); + + Report.Comment ("Testing indefinite tagged type.."); + TC_Person_Test (Person_Stack, FC50A00.TC_Person_Item); + + Report.Comment ("Testing class-wide type.."); + TC_People_Test (People_Stack, FC50A00.TC_VIPerson_Item); + + Report.Result; +end CC50A02; diff --git a/gcc/testsuite/ada/acats/tests/cc/cc51001.a b/gcc/testsuite/ada/acats/tests/cc/cc51001.a new file mode 100644 index 000000000..6aa76a6f8 --- /dev/null +++ b/gcc/testsuite/ada/acats/tests/cc/cc51001.a @@ -0,0 +1,186 @@ +-- CC51001.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 formal parameter of a generic package may be a formal +-- derived type. Check that the formal derived type may have an unknown +-- discriminant part. Check that the ancestor type in a formal derived +-- type definition may be a tagged type, and that the actual parameter +-- may be a descendant of the ancestor type. Check that the formal derived +-- type belongs to the derivation class rooted at the ancestor type; +-- specifically, that components of the ancestor type may be referenced +-- within the generic. Check that if a formal derived subtype is +-- indefinite then the actual may be either definite or indefinite. +-- +-- TEST DESCRIPTION: +-- Define a class of tagged types with a definite root type. Extend the +-- root type with a discriminated component. Since discriminants of +-- tagged types may not have defaults, the type is indefinite. +-- +-- Extend the extension with a second discriminated component, but with +-- a new discriminant part. Declare a generic package with a formal +-- derived type using the root type of the class as ancestor, and an +-- unknown discriminant part. Declare an operation in the generic which +-- accesses the common component of types in the class. +-- +-- In the main program, instantiate the generic with each type in the +-- class and verify that the operation correctly accesses the common +-- component. +-- +-- +-- CHANGE HISTORY: +-- 06 Dec 94 SAIC ACVC 2.0 +-- +--! + +package CC51001_0 is -- Root type for message class. + + subtype Msg_String is String (1 .. 20); + + type Msg_Type is tagged record -- Root type of + Text : Msg_String := (others => ' '); -- class (definite). + end record; + +end CC51001_0; + + +-- No body for CC51001_0. + + + --==================================================================-- + + +with CC51001_0; -- Root type for message class. +package CC51001_1 is -- Extensions to message class. + + subtype Source_Length is Natural range 0 .. 10; + + type From_Msg_Type (SLen : Source_Length) is -- Direct derivative + new CC51001_0.Msg_Type with record -- of root type + From : String (1 .. SLen); -- (indefinite). + end record; + + subtype Dest_Length is Natural range 0 .. 10; + + + + type To_From_Msg_Type (DLen : Dest_Length) is -- Indirect + new From_Msg_Type (SLen => 10) with record -- derivative of + To : String (1 .. DLen); -- root type + end record; -- (indefinite). + +end CC51001_1; + + +-- No body for CC51001_1. + + + --==================================================================-- + + +with CC51001_0; -- Root type for message class. +generic -- I/O operations for message class. + type Message_Type (<>) is new CC51001_0.Msg_Type with private; +package CC51001_2 is + + -- This subprogram contains an artificial result for testing purposes: + -- the function returns the text of the message to the caller as a string. + + function Print_Message (M : in Message_Type) return String; + + -- ... Other operations. + +end CC51001_2; + + + --==================================================================-- + + +package body CC51001_2 is + + -- The implementations of the operations below are purely artificial; the + -- validity of their implementations in the context of the abstraction is + -- irrelevant to the feature being tested. + + function Print_Message (M : in Message_Type) return String is + begin + return M.Text; + end Print_Message; + +end CC51001_2; + + + --==================================================================-- + + +with CC51001_0; -- Root type for message class. +with CC51001_1; -- Extensions to message class. +with CC51001_2; -- I/O operations for message class. + +with Report; +procedure CC51001 is + + -- Instantiate for various types in the class: + + package Msgs is new CC51001_2 (CC51001_0.Msg_Type); -- Definite. + package FMsgs is new CC51001_2 (CC51001_1.From_Msg_Type); -- Indefinite. + package TFMsgs is new CC51001_2 (CC51001_1.To_From_Msg_Type); -- Indefinite. + + + + Msg : CC51001_0.Msg_Type := (Text => "This is message #001"); + FMsg : CC51001_1.From_Msg_Type := (Text => "This is message #002", + SLen => 2, + From => "Me"); + TFMsg : CC51001_1.To_From_Msg_Type := (Text => "This is message #003", + From => "You ", + DLen => 4, + To => "Them"); + + Expected_Msg : constant String := "This is message #001"; + Expected_FMsg : constant String := "This is message #002"; + Expected_TFMsg : constant String := "This is message #003"; + +begin + Report.Test ("CC51001", "Check that the formal derived type may have " & + "an unknown discriminant part. Check that the ancestor " & + "type in a formal derived type definition may be a " & + "tagged type, and that the actual parameter may be any " & + "definite or indefinite descendant of the ancestor type"); + + if (Msgs.Print_Message (Msg) /= Expected_Msg) then + Report.Failed ("Wrong result for definite root type"); + end if; + + if (FMsgs.Print_Message (FMsg) /= Expected_FMsg) then + Report.Failed ("Wrong result for direct indefinite derivative"); + end if; + + if (TFMsgs.Print_Message (TFMsg) /= Expected_TFMsg) then + Report.Failed ("Wrong result for Indirect indefinite derivative"); + end if; + + Report.Result; +end CC51001; diff --git a/gcc/testsuite/ada/acats/tests/cc/cc51002.a b/gcc/testsuite/ada/acats/tests/cc/cc51002.a new file mode 100644 index 000000000..1083d18a8 --- /dev/null +++ b/gcc/testsuite/ada/acats/tests/cc/cc51002.a @@ -0,0 +1,198 @@ +-- CC51002.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 formal derived tagged types, the formal parameter +-- names and default expressions for a primitive subprogram in an +-- instance are determined by the primitive subprogram of the ancestor +-- type, but that the primitive subprogram body executed is that of the +-- actual type. +-- +-- TEST DESCRIPTION: +-- Define a root tagged type in a library-level package and give it a +-- primitive subprogram. Provide a default expression for a non-tagged +-- parameter of the subprogram. Declare a library-level generic subprogram +-- with a formal derived type using the root type as ancestor. Call +-- the primitive subprogram of the root type using named association for +-- the tagged parameter, and provide no actual for the defaulted +-- parameter. Extend the root type in a second package and override the +-- root type's subprogram with one which has different parameter names +-- and no default expression for the non-tagged parameter. Instantiate +-- the generic subprogram for each of the tagged types in the class and +-- call the instances. +-- +-- +-- CHANGE HISTORY: +-- 06 Dec 94 SAIC ACVC 2.0 +-- +--! + +package CC51002_0 is -- Root message type and operations. + + type Recipients is (None, Root, Sysop, Local, Remote); + + type Msg_Type is tagged record -- Root type of + Text : String (1 .. 10); -- class. + end record; + + function Send (Msg : in Msg_Type; -- Primitive + To : Recipients := Local) return Boolean; -- subprogram. + + -- ...Other message operations. + +end CC51002_0; + + + --==================================================================-- + + +package body CC51002_0 is + + -- The implementation of Send is purely artificial; the validity of + -- its implementation in the context of the abstraction is irrelevant to + -- the feature being tested. + + function Send (Msg : in Msg_Type; + To : Recipients := Local) return Boolean is + begin + return (Msg.Text = "Greetings!" and To = Local); + end Send; + +end CC51002_0; + + + --==================================================================-- + + +with CC51002_0; -- Root message type and operations. +generic -- Message class function. + type Msg_Block is new CC51002_0.Msg_Type with private; +function CC51002_1 (M : in Msg_Block) return Boolean; + + + --==================================================================-- + + +function CC51002_1 (M : in Msg_Block) return Boolean is + Okay : Boolean := False; +begin + + -- The call to Send below uses the ancestor type's parameter name, which + -- should be legal even if the actual subprogram called does not have a + -- parameter of that name. Furthermore, it uses the ancestor type's default + -- expression for the second parameter, which should be legal even if the + -- the actual subprogram called has no such default expression. + + Okay := Send (Msg => M); + -- ...Other processing. + return Okay; + +end CC51002_1; + + + --==================================================================-- + + +with CC51002_0; -- Root message type and operations. +package CC51002_2 is -- Extended message type and operations. + + type Sender_Type is (Inside, Outside); + + type Who_Msg_Type is new CC51002_0.Msg_Type with record -- Derivative of + From : Sender_Type; -- root type of + end record; -- class. + + + -- Note: this overriding version of Send has different parameter names + -- from the root type's function. It also has no default expression. + + function Send (M : Who_Msg_Type; -- Overrides + R : CC51002_0.Recipients) return Boolean; -- root type's + -- operation. + -- ...Other extended message operations. + +end CC51002_2; + + + --==================================================================-- + + +package body CC51002_2 is + + -- The implementation of Send is purely artificial; the validity of + -- its implementation in the context of the abstraction is irrelevant to + -- the feature being tested. + + function Send (M : Who_Msg_Type; R : CC51002_0.Recipients) return Boolean is + use type CC51002_0.Recipients; + begin + return (M.Text = "Willkommen" and + M.From = Outside and + R = CC51002_0.Local); + end Send; + +end CC51002_2; + + + --==================================================================-- + + +with CC51002_0; -- Root message type and operations. +with CC51002_1; -- Message class function. +with CC51002_2; -- Extended message type and operations. + +with Report; +procedure CC51002 is + + function Send_Msg is new CC51002_1 (CC51002_0.Msg_Type); + function Send_WMsg is new CC51002_1 (CC51002_2.Who_Msg_Type); + + Mess : CC51002_0.Msg_Type := (Text => "Greetings!"); + WMess : CC51002_2.Who_Msg_Type := (Text => "Willkommen", + From => CC51002_2.Outside); + + TC_Okay_MStatus : Boolean := False; + TC_Okay_WMStatus : Boolean := False; + +begin + Report.Test ("CC51002", "Check that, for formal derived tagged types, " & + "the formal parameter names and default expressions for " & + "a primitive subprogram in an instance are determined by " & + "the primitive subprogram of the ancestor type, but that " & + "the primitive subprogram body executed is that of the" & + "actual type"); + + TC_Okay_MStatus := Send_Msg (Mess); + if not TC_Okay_MStatus then + Report.Failed ("Wrong result from call to root type's operation"); + end if; + + TC_Okay_WMStatus := Send_WMsg (WMess); + if not TC_Okay_WMStatus then + Report.Failed ("Wrong result from call to derived type's operation"); + end if; + + Report.Result; +end CC51002; diff --git a/gcc/testsuite/ada/acats/tests/cc/cc51003.a b/gcc/testsuite/ada/acats/tests/cc/cc51003.a new file mode 100644 index 000000000..68ea32ebd --- /dev/null +++ b/gcc/testsuite/ada/acats/tests/cc/cc51003.a @@ -0,0 +1,187 @@ +-- CC51003.A +-- +-- Grant of Unlimited Rights +-- +-- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687, +-- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained +-- unlimited rights in the software and documentation contained herein. +-- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making +-- this public release, the Government intends to confer upon all +-- recipients unlimited rights equal to those held by the Government. +-- These rights include rights to use, duplicate, release or disclose the +-- released technical data and computer software in whole or in part, in +-- any manner and for any purpose whatsoever, and to have or permit others +-- to do so. +-- +-- DISCLAIMER +-- +-- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR +-- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED +-- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE +-- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE +-- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A +-- PARTICULAR PURPOSE OF SAID MATERIAL. +--* +-- +-- OBJECTIVE: +-- Check that if the ancestor type of a formal derived type is a composite +-- type that is not an array type, the formal type inherits components, +-- including discriminants, from the ancestor type. +-- +-- Check for the case where the ancestor type is a record type, and the +-- formal derived type is declared in a generic subprogram. +-- +-- TEST DESCRIPTION: +-- Define a discriminated record type in a package. Declare a +-- library-level generic subprogram with a formal derived type using the +-- record type as ancestor. Give the generic subprogram an in out +-- parameter of the formal derived type. Inside the generic, use the +-- discriminant component and modify the remaining components of the +-- record parameter. In the main program, declare record objects with two +-- different discriminant values. Derive an indefinite type from the +-- record type with a new discriminant part. Instantiate the generic +-- subprogram for the root record subtype and the derived subtype. Call +-- the root subtype instance with actual parameters having the two +-- discriminant values. Also call the derived subtype instance with +-- an appropriate actual. +-- +-- +-- CHANGE HISTORY: +-- 06 Dec 94 SAIC ACVC 2.0 +-- 03 Jan 95 SAIC Removed unknown discriminant part from formal +-- derived type. +-- 05 Nov 95 SAIC ACVC 2.0.1 fixes: Removed constrained subtype +-- instantiation and associated declarations. +-- Modified commentary. +-- +--! + + +-- Simulate a fragment of a matrix manipulation application. + +package CC51003_0 is -- Matrix types. + + type Matrix is array (Natural range <>, Natural range <>) of Integer; + + type Square (Side : Natural) is record + Mat : Matrix (1 .. Side, 1 .. Side); + end record; + + type Double_Square (Number : Natural) is record + Left : Square (Number); + Right : Square (Number); + end record; + +end CC51003_0; + + +-- No body for CC51003_0; + + + --==================================================================-- + + +with CC51003_0; -- Matrix types. +generic -- Generic double-matrix "clear" operation. + type Dbl_Square is new CC51003_0.Double_Square; -- Indefinite +procedure CC51003_1 (Dbl : in out Dbl_Square); -- formal. + + + --==================================================================-- + + +procedure CC51003_1 (Dbl : in out Dbl_Square) is +begin + for I in 1 .. Dbl.Number loop -- Discriminants inherited from ancestor + for J in 1 .. Dbl.Number loop -- type (should work even for derived type + -- declaring new discriminant part). + Dbl.Left.Mat (I, J) := 0; -- Other components inherited from + Dbl.Right.Mat (I, J) := 0; -- ancestor type. + + end loop; + end loop; +end CC51003_1; + + + --==================================================================-- + + +with CC51003_0; -- Matrix types. +with CC51003_1; -- Generic double-matrix "clear" operation. + +with Report; +procedure CC51003 is + + use CC51003_0; -- "/=" operator directly visible for Double_Square. + + -- Matrices of root type: + + Mat_2x2 : Square(Side => 2) := (Side => 2, + Mat => ( (1, 2), (3, 4) )); + Dbl_Mat_2x2 : Double_Square(Number => 2) := (2, Mat_2x2, Mat_2x2); + + + Zero_2x2 : constant Square(2) := (2, Mat => ( (0, 0), (0, 0) )); + Expected_2x2 : constant Double_Square(2) := (Number => 2, + others => Zero_2x2); + + + + Mat_3x3 : Square(Side => 3) := (Side => 3, + Mat => (1 => (1, 4, 9), + others => (1 => 5, + others => 7))); + Dbl_Mat_3x3 : Double_Square(3) := (Number => 3, others => Mat_3x3); + + + Zero_3x3 : constant Square(3) := (3, Mat => (others => (0,0,0))); + Expected_3x3 : constant Double_Square(Number => 3) := + (3, Zero_3x3, Zero_3x3); + + + -- Derived type with new discriminant part (which constrains parent): + + type New_Dbl_Sq (Num : Natural) is new Double_Square(Num); + + New_Dbl_2x2 : New_Dbl_Sq (Num => 2) := (2, Mat_2x2, Mat_2x2); + Expected_New_2x2 : constant New_Dbl_Sq := (Num => 2, others => Zero_2x2); + + + + -- Instantiations: + + procedure Clr_Dbl is new CC51003_1 (Double_Square); + procedure Clr_New_Dbl is new CC51003_1 (New_Dbl_Sq); + + +begin + Report.Test ("CC51003", "Check that a formal derived record type " & + "inherits components, including discriminants, " & + "from its ancestor type"); + + -- Simulate use of matrix manipulation operations. + + Clr_Dbl (Dbl_Mat_2x2); + + if (Dbl_Mat_2x2 /= Expected_2x2) then + Report.Failed ("Wrong result for root type (2x2 matrix)"); + end if; + + + Clr_Dbl (Dbl_Mat_3x3); + + if (Dbl_Mat_3x3 /= Expected_3x3) then + Report.Failed ("Wrong result for root type (3x3 matrix)"); + end if; + + + Clr_New_Dbl (New_Dbl_2x2); + + if (New_Dbl_2x2 /= Expected_New_2x2) then + Report.Failed ("Wrong result for derived type (2x2 matrix)"); + end if; + + + Report.Result; + +end CC51003; diff --git a/gcc/testsuite/ada/acats/tests/cc/cc51004.a b/gcc/testsuite/ada/acats/tests/cc/cc51004.a new file mode 100644 index 000000000..09b1b57fa --- /dev/null +++ b/gcc/testsuite/ada/acats/tests/cc/cc51004.a @@ -0,0 +1,181 @@ +-- CC51004.A +-- +-- Grant of Unlimited Rights +-- +-- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687, +-- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained +-- unlimited rights in the software and documentation contained herein. +-- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making +-- this public release, the Government intends to confer upon all +-- recipients unlimited rights equal to those held by the Government. +-- These rights include rights to use, duplicate, release or disclose the +-- released technical data and computer software in whole or in part, in +-- any manner and for any purpose whatsoever, and to have or permit others +-- to do so. +-- +-- DISCLAIMER +-- +-- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR +-- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED +-- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE +-- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE +-- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A +-- PARTICULAR PURPOSE OF SAID MATERIAL. +--* +-- +-- OBJECTIVE: +-- Check that if the ancestor type of a formal derived type is a composite +-- type that is not an array type, the formal type inherits components, +-- including discriminants, from the ancestor type. +-- +-- Check for the case where the ancestor type is a tagged type, and the +-- formal derived type is declared in a generic subprogram. +-- +-- TEST DESCRIPTION: +-- Define a discriminated tagged type in a package. Declare a +-- library-level generic subprogram with a formal derived type using the +-- tagged type as ancestor. Give the generic subprogram an in out +-- parameter of the formal derived type. Inside the generic, use the +-- discriminant component and modify the remaining components of the +-- tagged parameter. In the main program, declare tagged record objects +-- with two different discriminant values. Derive an indefinite type from +-- the tagged type with a new discriminant part. Instantiate the +-- generic subprogram for the root tagged subtype and the derived subtype. +-- Call the root subtype instance with actual parameters having the two +-- discriminant values. Also call the derived subtype instance with an +-- appropriate actual. +-- +-- +-- CHANGE HISTORY: +-- 06 Dec 94 SAIC ACVC 2.0 +-- 05 Jan 94 SAIC Removed unknown discriminant part from formal +-- derived type. Moved declaration of type +-- New_Dbl_Sq from main subprogram to CC51004_0. +-- 05 Nov 95 SAIC ACVC 2.0.1 fixes: Removed constrained subtype +-- instantiation and associated declarations. +-- Modified commentary. +-- +--! + +-- Simulate a fragment of a matrix manipulation application. + +package CC51004_0 is -- Matrix types. + + type Matrix is array (Natural range <>, Natural range <>) of Integer; + + type Square (Side : Natural) is record + Mat : Matrix (1 .. Side, 1 .. Side); + end record; + + type Sq_Type (Num1 : Natural) is tagged record + One : Square (Num1); + end record; + + -- Extended type with new discriminant part (which constrains parent): + + type New_Dbl_Sq (Num2 : Natural) is new Sq_Type(Num2) with record + Two : Square (Num2); + end record; + +end CC51004_0; + + +-- No body for CC51004_0; + + + --==================================================================-- + + +with CC51004_0; -- Matrix types. +generic -- Generic matrix "clear" operation. + type Squares is new CC51004_0.Sq_Type with private; -- Indefinite +procedure CC51004_1 (Sq : in out Squares); -- formal. + + + --==================================================================-- + + +procedure CC51004_1 (Sq : in out Squares) is +begin + for I in 1 .. Sq.Num1 loop -- Discriminants inherited from ancestor + for J in 1 .. Sq.Num1 loop -- type (should work even for derived type + -- declaring new discriminant part). + Sq.One.Mat (I, J) := 0; -- Other components inherited from + -- ancestor type. + end loop; + end loop; +end CC51004_1; + + + --==================================================================-- + + +with CC51004_0; -- Matrix types. +with CC51004_1; -- Generic double-matrix "clear" operation. + +with Report; +procedure CC51004 is + + use CC51004_0; -- "/=" operator directly visible for Sq_Type. + + -- Matrices of root type: + + Mat_2x2 : Square(Side => 2) := (Side => 2, Mat => ( (1, 2), (3, 4) )); + One_Mat_2x2 : Sq_Type(Num1 => 2) := (2, Mat_2x2); + + Zero_2x2 : constant Square(2) := (2, Mat => ( (0, 0), (0, 0) )); + Expected_2x2 : constant Sq_Type(2) := (Num1 => 2, One => Zero_2x2); + + + Mat_3x3 : Square(Side => 3) := (Side => 3, + Mat => (1 => (5, 2, 7), + others => (1 => 4, + others => 9))); + One_Mat_3x3 : Sq_Type(3) := (Num1 => 3, One => Mat_3x3); + + Zero_3x3 : constant Square(3) := (3, Mat => (others => (0,0,0))); + Expected_3x3 : constant Sq_Type(Num1 => 3) := (3, Zero_3x3); + + + New_Dbl_2x2 : New_Dbl_Sq(Num2 => 2) := (2, others => Mat_2x2); + Expected_New_2x2 : constant New_Dbl_Sq := (2, Zero_2x2, Mat_2x2); + + + + -- Instantiations: + + procedure Clr_Mat is new CC51004_1 (Sq_Type); + procedure Clr_New_Dbl is new CC51004_1 (New_Dbl_Sq); + + +begin + Report.Test ("CC51004", "Check that a formal derived tagged type " & + "inherits components, including discriminants, " & + "from its ancestor type"); + + -- Simulate use of matrix manipulation operations. + + + Clr_Mat (One_Mat_2x2); + + if (One_Mat_2x2 /= Expected_2x2) then + Report.Failed ("Wrong result root type (2x2 matrix)"); + end if; + + + Clr_Mat (One_Mat_3x3); + + if (One_Mat_3x3 /= Expected_3x3) then + Report.Failed ("Wrong result root type (3x3 matrix)"); + end if; + + + Clr_New_Dbl (New_Dbl_2x2); + + if (New_Dbl_2x2 /= Expected_New_2x2) then + Report.Failed ("Wrong result extended type (2x2 matrix)"); + end if; + + + Report.Result; +end CC51004; diff --git a/gcc/testsuite/ada/acats/tests/cc/cc51006.a b/gcc/testsuite/ada/acats/tests/cc/cc51006.a new file mode 100644 index 000000000..b4dc4cdb4 --- /dev/null +++ b/gcc/testsuite/ada/acats/tests/cc/cc51006.a @@ -0,0 +1,224 @@ +-- CC51006.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, in an instance, each implicit declaration of a primitive +-- subprogram of a formal (nontagged) derived type declares a view of +-- the corresponding primitive subprogram of the ancestor type, even if +-- the subprogram has been overridden for the actual type. Check that for +-- a formal derived type with no discriminant part, if the ancestor +-- subtype is an unconstrained scalar subtype then the actual may be +-- either constrained or unconstrained. +-- +-- TEST DESCRIPTION: +-- The formal derived type has no discriminant part, but the ancestor +-- subtype is unconstrained, making the formal type unconstrained. Since +-- the ancestor subtype is a scalar subtype (not an access or composite +-- subtype), the actual may be either constrained or unconstrained. +-- +-- Declare a root type of a class as an unconstrained scalar (use floating +-- point). Declare a primitive subprogram of the root type. Declare a +-- generic package which has a formal derived type with the scalar root +-- type as ancestor. Inside the generic, declare an operation which calls +-- the ancestor type's primitive subprogram. Derive both constrained and +-- unconstrained types from the root type and override the primitive +-- subprogram for each. Declare a constrained subtype of the unconstrained +-- derivative. Instantiate the generic package for the derived types and +-- the subtype and call the "generic" operation for each one. Confirm that +-- in all cases the root type's implementation of the primitive +-- subprogram is called. +-- +-- +-- CHANGE HISTORY: +-- 06 Dec 94 SAIC ACVC 2.0 +-- +--! + +package CC51006_0 is -- Weight class. + + type Weight_Type is digits 3; -- Root type of class (unconstrained). + + function Weight_To_String (Wt : Weight_Type) return String; + + -- ... Other operations. + +end CC51006_0; + + + --==================================================================-- + + +package body CC51006_0 is + + -- The implementations of the operations below are purely artificial; the + -- validity of their implementations in the context of the abstraction is + -- irrelevant to the feature being tested. + + function Weight_To_String (Wt : Weight_Type) return String is + begin + if Wt > 0.0 then -- Always true for this test. + return ("Root type's implementation called"); + else + return ("Unexpected result "); + end if; + end Weight_To_String; + +end CC51006_0; + + + --==================================================================-- + + +with CC51006_0; -- Weight class. +generic -- Generic weight operations. + type Weight is new CC51006_0.Weight_Type; +package CC51006_1 is + + procedure Output_Weight (Wt : in Weight; TC_Return : out String); + + -- ... Other operations. + +end CC51006_1; + + + --==================================================================-- + + +package body CC51006_1 is + + + -- The implementation of this procedure is purely artificial, and contains + -- an artificial parameter for testing purposes: the procedure returns the + -- weight string to the caller. + + procedure Output_Weight (Wt : in Weight; TC_Return : out String) is + begin + TC_Return := Weight_To_String (Wt); -- Should always call root type's + end Output_Weight; -- implementation. + + +end CC51006_1; + + + --==================================================================-- + + +with CC51006_0; -- Weight class. +use CC51006_0; +package CC51006_2 is -- Extensions to weight class. + + type Grams is new Weight_Type; -- Unconstrained + -- derivative. + + function Weight_To_String (Wt : Grams) return String; -- Overrides root + -- type's operation. + + subtype Milligrams is Grams -- Constrained + range 0.0 .. 0.999; -- subtype (of der.). + + type Pounds is new Weight_Type -- Constrained + range 0.0 .. 500.0; -- derivative. + + function Weight_To_String (Wt : Pounds) return String; -- Overrides root + -- type's operation. + +end CC51006_2; + + + --==================================================================-- + + +package body CC51006_2 is + + -- The implementations of the operations below are purely artificial; the + -- validity of their implementations in the context of the abstraction is + -- irrelevant to the feature being tested. + + function Weight_To_String (Wt : Grams) return String is + begin + return ("GRAMS: Should never be called "); + end Weight_To_String; + + + function Weight_To_String (Wt : Pounds) return String is + begin + return ("POUNDS: Should never be called "); + end Weight_To_String; + +end CC51006_2; + + + --==================================================================-- + + +with CC51006_1; -- Generic weight operations. +with CC51006_2; -- Extensions to weight class. + +with Report; +procedure CC51006 is + + package Metric_Wts_G is new CC51006_1 (CC51006_2.Grams); -- Unconstr. + package Metric_Wts_MG is new CC51006_1 (CC51006_2.Milligrams); -- Constr. + package US_Wts is new CC51006_1 (CC51006_2.Pounds); -- Constr. + + Gms : CC51006_2.Grams := 113.451; + Mgm : CC51006_2.Milligrams := 0.549; + Lbs : CC51006_2.Pounds := 24.52; + + + subtype TC_Buffers is String (1 .. 33); + + TC_Expected : constant TC_Buffers := "Root type's implementation called"; + TC_Buffer : TC_Buffers; + +begin + Report.Test ("CC51006", "Check that, in an instance, each implicit " & + "declaration of a primitive subprogram of a formal " & + "(nontagged) type declares a view of the corresponding " & + "primitive subprogram of the ancestor type"); + + + Metric_Wts_G.Output_Weight (Gms, TC_Buffer); + + if TC_Buffer /= TC_Expected then + Report.Failed ("Root operation not called for unconstrained derivative"); + end if; + + + Metric_Wts_MG.Output_Weight (Mgm, TC_Buffer); + + if TC_Buffer /= TC_Expected then + Report.Failed ("Root operation not called for constrained subtype"); + end if; + + + US_Wts.Output_Weight (Lbs, TC_Buffer); + + if TC_Buffer /= TC_Expected then + Report.Failed ("Root operation not called for constrained derivative"); + end if; + + Report.Result; +end CC51006; diff --git a/gcc/testsuite/ada/acats/tests/cc/cc51007.a b/gcc/testsuite/ada/acats/tests/cc/cc51007.a new file mode 100644 index 000000000..d8f78779d --- /dev/null +++ b/gcc/testsuite/ada/acats/tests/cc/cc51007.a @@ -0,0 +1,305 @@ +-- CC51007.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 generic formal derived tagged type is a private extension. +-- Specifically, check that, for a generic formal derived type whose +-- ancestor type has abstract primitive subprograms, neither the formal +-- derived type nor its descendants need be abstract. Check that objects +-- and components of the formal derived type and its nonabstract +-- descendants may be declared and allocated, as may nonabstract +-- functions returning these types, and that aggregates of nonabstract +-- descendants of the formal derived type are legal. Check that calls to +-- the abstract primitive subprograms of the ancestor dispatch to the +-- bodies corresponding to the tag of the actual parameters. +-- +-- TEST DESCRIPTION: +-- Although the ancestor type is abstract and has abstract primitive +-- subprograms, these subprograms, when inherited by a formal nonabstract +-- derived type, are not abstract, since the formal derived type is a +-- nonabstract private extension. +-- +-- Thus, derivatives of the formal derived type need not be abstract, +-- and both the formal derived type and its derivatives are considered +-- nonabstract types. +-- +-- This test verifies that the restrictions placed on abstract types do +-- not apply to the formal derived type or its derivatives. Specifically, +-- objects of, components of, allocators of, and nonabstract functions +-- returning the formal derived type or its derivatives are legal. In +-- addition, the test verifies that a call within the instance to a +-- primitive subprogram of the (abstract) ancestor type dispatches to +-- the body corresponding to the tag of the actual parameter. +-- +-- +-- CHANGE HISTORY: +-- 06 Dec 94 SAIC ACVC 2.0 +-- 23 Dec 94 SAIC Deleted illegal extension aggregate. Corrected +-- dispatching call. Editorial changes to commentary. +-- 05 Nov 95 SAIC ACVC 2.0.1 fixes: Moved instantiation of CC51007_3 +-- to library level. +-- 11 Aug 96 SAIC ACVC 2.1: Added pragma Elaborate to context +-- clauses of CC51007_1 and CC51007_4. +-- +--! + +package CC51007_0 is + + Max_Length : constant := 10; + type Text is new String(1 .. Max_Length); + + type Alert is abstract tagged record -- Root type of class + Message : Text := (others => '*'); -- (abstract). + end record; + + procedure Handle (A: in out Alert) is abstract; -- Abstract dispatching + -- operation. + +end CC51007_0; + +-- No body for CC51007_0; + + + --===================================================================-- + + +with CC51007_0; + +with Ada.Calendar; +pragma Elaborate (Ada.Calendar); + +package CC51007_1 is + + type Low_Alert is new CC51007_0.Alert with record + Time_Of_Arrival : Ada.Calendar.Time := Ada.Calendar.Time_Of (1901, 8, 1); + end record; + + procedure Handle (A: in out Low_Alert); -- Overrides parent's + -- implementation. + Low : Low_Alert; + +end CC51007_1; + + + --===================================================================-- + + +package body CC51007_1 is + + procedure Handle (A: in out Low_Alert) is -- Artificial for + begin -- testing. + A.Time_Of_Arrival := Ada.Calendar.Time_Of (1984, 1, 1); + A.Message := "Low Alert!"; + end Handle; + +end CC51007_1; + + + --===================================================================-- + + +with CC51007_1; +package CC51007_2 is + + type Person is (OOD, CO, CinC); + + type Medium_Alert is new CC51007_1.Low_Alert with record + Action_Officer : Person := OOD; + end record; + + procedure Handle (A: in out Medium_Alert); -- Overrides parent's + -- implementation. + Med : Medium_Alert; + +end CC51007_2; + + + --===================================================================-- + + +with Ada.Calendar; +package body CC51007_2 is + + procedure Handle (A: in out Medium_Alert) is -- Artificial for + begin -- testing. + A.Action_Officer := CO; + A.Time_Of_Arrival := Ada.Calendar.Time_Of (2001, 1, 1); + A.Message := "Med Alert!"; + end Handle; + +end CC51007_2; + + + --===================================================================-- + + +with CC51007_0; +generic + type Alert_Type is new CC51007_0.Alert with private; + Initial_State : in Alert_Type; +package CC51007_3 is + + function Clear_Message (A: Alert_Type) -- Function returning + return Alert_Type; -- formal type. + + + Max_Note : Natural := 10; + type Note is new String (1 .. Max_Note); + + type Extended_Alert is new Alert_Type with record + Addendum : Note := (others => '*'); + end record; + + -- In instance, inherits version of Handle from + -- actual corresponding to formal type. + + function Annotate_Alert (A: in Alert_Type'Class) -- Function returning + return Extended_Alert; -- derived type. + + + Init_Ext_Alert : constant Extended_Alert := -- Object declaration. + (Initial_State with Addendum => "----------"); -- Aggregate. + + + type Alert_Type_Ptr is access constant Alert_Type; + type Ext_Alert_Ptr is access Extended_Alert; + + Init_Alert_Ptr : Alert_Type_Ptr := + new Alert_Type'(Initial_State); -- Allocator. + + Init_Ext_Alert_Ptr : Ext_Alert_Ptr := + new Extended_Alert'(Init_Ext_Alert); -- Allocator. + + + type Alert_Pair is record + A : Alert_Type; -- Component. + EA : Extended_Alert; -- Component. + end record; + +end CC51007_3; + + + --===================================================================-- + + +package body CC51007_3 is + + function Clear_Message (A: Alert_Type) return Alert_Type is + Temp : Alert_Type := A; -- Object declaration. + begin + Temp.Message := (others => '-'); + return Temp; + end Clear_Message; + + function Annotate_Alert (A: in Alert_Type'Class) return Extended_Alert is + Temp : Alert_Type'Class := A; + begin + Handle (Temp); -- Dispatching call to + -- operation of ancestor. + return (Alert_Type(Temp) with Addendum => "No comment"); + end Annotate_Alert; + +end CC51007_3; + + + --===================================================================-- + + +with CC51007_1; + +with CC51007_3; +pragma Elaborate (CC51007_3); + +package CC51007_4 is new CC51007_3 (CC51007_1.Low_Alert, CC51007_1.Low); + + + --===================================================================-- + + +with CC51007_1; +with CC51007_2; +with CC51007_3; +with CC51007_4; + +with Ada.Calendar; +with Report; +procedure CC51007 is + + package Alert_Support renames CC51007_4; + + Ext : Alert_Support.Extended_Alert; + + TC_Result : Alert_Support.Extended_Alert; + + TC_Low_Expected : constant Alert_Support.Extended_Alert := + (Time_Of_Arrival => Ada.Calendar.Time_Of (1984, 1, 1), + Message => "Low Alert!", + Addendum => "No comment"); + + TC_Med_Expected : constant Alert_Support.Extended_Alert := + (Time_Of_Arrival => Ada.Calendar.Time_Of (2001, 1, 1), + Message => "Med Alert!", + Addendum => "No comment"); + + TC_Ext_Expected : constant Alert_Support.Extended_Alert := TC_Low_Expected; + + + use type Alert_Support.Extended_Alert; + +begin + Report.Test ("CC51007", "Check that, for a generic formal derived type " & + "whose ancestor type has abstract primitive subprograms, " & + "neither the formal derived type nor its descendants need " & + "be abstract, and that objects of, components of, " & + "allocators of, aggregates of, and nonabstract functions " & + "returning these types are legal. Check that calls to the " & + "abstract primitive subprograms of the ancestor dispatch " & + "to the bodies corresponding to the tag of the actual " & + "parameters"); + + + TC_Result := Alert_Support.Annotate_Alert (CC51007_1.Low); -- Dispatching + -- call. + if TC_Result /= TC_Low_Expected then + Report.Failed ("Wrong results from dispatching call (Low_Alert)"); + end if; + + + TC_Result := Alert_Support.Annotate_Alert (CC51007_2.Med); -- Dispatching + -- call. + if TC_Result /= TC_Med_Expected then + Report.Failed ("Wrong results from dispatching call (Medium_Alert)"); + end if; + + + TC_Result := Alert_Support.Annotate_Alert (Ext); -- Results in dispatching + -- call. + if TC_Result /= TC_Ext_Expected then + Report.Failed ("Wrong results from dispatching call (Extended_Alert)"); + end if; + + + Report.Result; +end CC51007; diff --git a/gcc/testsuite/ada/acats/tests/cc/cc51008.a b/gcc/testsuite/ada/acats/tests/cc/cc51008.a new file mode 100644 index 000000000..b95ae6cf0 --- /dev/null +++ b/gcc/testsuite/ada/acats/tests/cc/cc51008.a @@ -0,0 +1,124 @@ +-- CC51008.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 ACAA MAKES NO EXPRESS OR IMPLIED +-- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF 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 operations are inherited for a formal derived type whose +-- ancestor is also a formal type as described in the corrigendum. +-- (Defect Report 8652/0038, as reflected in Technical Corrigendum 1, +-- RM95 12.5.1(21/1)). +-- +-- CHANGE HISTORY: +-- 29 Jan 2001 PHL Initial version. +-- 30 Apr 2002 RLB Readied for release. +-- +--! +package CC51008_0 is + + type R0 is + record + C : Float; + end record; + + procedure S (X : R0); + +end CC51008_0; + +with Report; +use Report; +package body CC51008_0 is + procedure S (X : R0) is + begin + Comment ("CC51008_0.S called"); + end S; +end CC51008_0; + +with CC51008_0; +generic + type F1 is new CC51008_0.R0; + type F2 is new F1; +package CC51008_1 is + procedure G (O1 : F1; O2 : F2); +end CC51008_1; + +package body CC51008_1 is + procedure G (O1 : F1; O2 : F2) is + begin + S (O1); + S (O2); + end G; +end CC51008_1; + +with CC51008_0; +package CC51008_2 is + type R2 is new CC51008_0.R0; + procedure S (X : out R2); +end CC51008_2; + +with Report; +use Report; +package body CC51008_2 is + procedure S (X : out R2) is + begin + Failed ("CC51008_2.S called"); + end S; +end CC51008_2; + +with CC51008_2; +package CC51008_3 is + type R3 is new CC51008_2.R2; + procedure S (X : R3); +end CC51008_3; + +with Report; +use Report; +package body CC51008_3 is + procedure S (X : R3) is + begin + Failed ("CC51008_3.S called"); + end S; +end CC51008_3; + +with CC51008_1; +with CC51008_2; +with CC51008_3; +with Report; +use Report; +procedure CC51008 is + + package Inst is new CC51008_1 (CC51008_2.R2, + CC51008_3.R3); + + X2 : constant CC51008_2.R2 := (C => 2.0); + X3 : constant CC51008_3.R3 := (C => 3.0); + +begin + Test ("CC51008", + "Check that operations are inherited for a formal derived " & + "type whose ancestor is also a formal type as described in " & + "RM95 12.5.1(21/1)"); + Inst.G (X2, X3); + Result; +end CC51008; + diff --git a/gcc/testsuite/ada/acats/tests/cc/cc51a01.a b/gcc/testsuite/ada/acats/tests/cc/cc51a01.a new file mode 100644 index 000000000..60c32be47 --- /dev/null +++ b/gcc/testsuite/ada/acats/tests/cc/cc51a01.a @@ -0,0 +1,193 @@ +-- CC51A01.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, in an instance, each implicit declaration of a user-defined +-- subprogram of a formal derived record type declares a view of the +-- corresponding primitive subprogram of the ancestor, even if the +-- primitive subprogram has been overridden for the actual type. +-- +-- TEST DESCRIPTION: +-- Declare a "fraction" type abstraction in a package (foundation code). +-- Declare a "fraction" I/O routine in a generic package with a formal +-- derived type whose ancestor type is the fraction type declared in +-- the first package. Within the I/O routine, call other operations of +-- ancestor type. Derive from the root fraction type in another package +-- and override one of the operations called in the generic I/O routine. +-- Derive from the derivative of the root fraction type. Instantiate +-- the generic package for each of the three types and call the I/O +-- routine. +-- +-- TEST FILES: +-- The following files comprise this test: +-- +-- FC51A00.A +-- CC51A01.A +-- +-- +-- CHANGE HISTORY: +-- 06 Dec 94 SAIC ACVC 2.0 +-- +--! + +with FC51A00; -- Fraction type abstraction. +generic -- Fraction I/O support. + type Fraction is new FC51A00.Fraction_Type; -- Formal derived type of a +package CC51A01_0 is -- (private) record type. + + -- Simulate writing a fraction to standard output. In a real application, + -- this subprogram might be a procedure which uses Text_IO routines. For + -- the purposes of the test, the "output" is returned to the caller as a + -- string. + function Put (Item : in Fraction) return String; + + -- ... Other I/O operations for fractions. + +end CC51A01_0; + + + --==================================================================-- + + +package body CC51A01_0 is + + function Put (Item : in Fraction) return String is + Num : constant String := -- Fraction's primitive subprograms + Integer'Image (Numerator (Item)); -- are inherited from its parent + Den : constant String := -- (FC51A00.Fraction_Type) and NOT + Integer'Image (Denominator (Item)); -- from the actual type. + begin + return (Num & '/' & Den); + end Put; + +end CC51A01_0; + + + --==================================================================-- + + +with FC51A00; -- Fraction type abstraction. +package CC51A01_1 is + + -- Derive directly from the root type of the class and override one of the + -- primitive subprograms. + + type Pos_Fraction is new FC51A00.Fraction_Type; -- Derived directly from + -- root type of class. + -- Inherits "/" from root type. + -- Inherits "-" from root type. + -- Inherits Numerator from root type. + -- Inherits Denominator from root type. + + -- Return absolute value of numerator as integer. + function Numerator (Frac : Pos_Fraction) -- Overrides parent's + return Integer; -- operation. + +end CC51A01_1; + + + --==================================================================-- + + +package body CC51A01_1 is + + -- This body should never be called. + -- + -- The test sends the function Numerator a fraction with a negative + -- numerator, and expects this negative numerator to be returned. This + -- version of the function returns the absolute value of the numerator. + -- Thus, a call to this version is detectable by examining the sign + -- of the return value. + + function Numerator (Frac : Pos_Fraction) return Integer is + Converted_Frac : FC51A00.Fraction_Type := FC51A00.Fraction_Type (Frac); + Orig_Numerator : Integer := FC51A00.Numerator (Converted_Frac); + begin + return abs (Orig_Numerator); + end Numerator; + +end CC51A01_1; + + + --==================================================================-- + + +with FC51A00; -- Fraction type abstraction. +with CC51A01_0; -- Fraction I/O support. +with CC51A01_1; -- Positive fraction type abstraction. + +with Report; +procedure CC51A01 is + + type Distance is new CC51A01_1.Pos_Fraction; -- Derived indirectly from + -- root type of class. + -- Inherits "/" indirectly from root type. + -- Inherits "-" indirectly from root type. + -- Inherits Numerator directly from parent type. + -- Inherits Denominator indirectly from root type. + + use FC51A00, CC51A01_1; -- All primitive subprograms + -- directly visible. + + package Fraction_IO is new CC51A01_0 (Fraction_Type); + package Pos_Fraction_IO is new CC51A01_0 (Pos_Fraction); + package Distance_IO is new CC51A01_0 (Distance); + + -- For each of the instances above, the subprogram "Put" should produce + -- the same result. That is, the primitive subprograms called by Put + -- should in all cases be those of the type Fraction_Type, which is the + -- ancestor type for the formal derived type in the generic unit. In + -- particular, for Pos_Fraction_IO and Distance_IO, the versions of + -- Numerator called should NOT be those of the actual types, which override + -- Fraction_Type's version. + + TC_Expected_Result : constant String := "-3/ 16"; + + TC_Root_Type_Of_Class : Fraction_Type := -3/16; + TC_Direct_Derivative : Pos_Fraction := -3/16; + TC_Indirect_Derivative : Distance := -3/16; + +begin + Report.Test ("CC51A01", "Check that, in an instance, each implicit " & + "declaration of a user-defined subprogram of a formal " & + "derived record type declares a view of the corresponding " & + "primitive subprogram of the ancestor, even if the " & + "primitive subprogram has been overridden for the actual " & + "type"); + + if (Fraction_IO.Put (TC_Root_Type_Of_Class) /= TC_Expected_Result) then + Report.Failed ("Wrong result for root type"); + end if; + + if (Pos_Fraction_IO.Put (TC_Direct_Derivative) /= TC_Expected_Result) then + Report.Failed ("Wrong result for direct derivative"); + end if; + + if (Distance_IO.Put (TC_Indirect_Derivative) /= TC_Expected_Result) then + Report.Failed ("Wrong result for INdirect derivative"); + end if; + + Report.Result; +end CC51A01; diff --git a/gcc/testsuite/ada/acats/tests/cc/cc51b03.a b/gcc/testsuite/ada/acats/tests/cc/cc51b03.a new file mode 100644 index 000000000..0cbeeb46f --- /dev/null +++ b/gcc/testsuite/ada/acats/tests/cc/cc51b03.a @@ -0,0 +1,258 @@ +-- CC51B03.A +-- +-- Grant of Unlimited Rights +-- +-- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687, +-- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained +-- unlimited rights in the software and documentation contained herein. +-- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making +-- this public release, the Government intends to confer upon all +-- recipients unlimited rights equal to those held by the Government. +-- These rights include rights to use, duplicate, release or disclose the +-- released technical data and computer software in whole or in part, in +-- any manner and for any purpose whatsoever, and to have or permit others +-- to do so. +-- +-- DISCLAIMER +-- +-- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR +-- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED +-- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE +-- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE +-- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A +-- PARTICULAR PURPOSE OF SAID MATERIAL. +--* +-- +-- OBJECTIVE: +-- Check that the attribute S'Definite, where S is an indefinite formal +-- private or derived type, returns true if the actual corresponding to +-- S is definite, and returns false otherwise. +-- +-- TEST DESCRIPTION: +-- A definite subtype is any subtype which is not indefinite. An +-- indefinite subtype is either: +-- a) An unconstrained array subtype. +-- b) A subtype with unknown discriminants (this includes class-wide +-- types). +-- c) A subtype with unconstrained discriminants without defaults. +-- +-- The possible forms of indefinite formal subtype are as follows: +-- +-- Formal derived types: +-- X - Ancestor is an unconstrained array type +-- * - Ancestor is a discriminated record type without defaults +-- X - Ancestor is a discriminated tagged type +-- * - Ancestor type has unknown discriminants +-- - Formal type has an unknown discriminant part +-- * - Formal type has a known discriminant part +-- +-- Formal private types: +-- - Formal type has an unknown discriminant part +-- * - Formal type has a known discriminant part +-- +-- The formal subtypes preceded by an 'X' above are not covered, because +-- other rules prevent a definite subtype from being passed as an actual. +-- The formal subtypes preceded by an '*' above are not covered, because +-- 'Definite is less likely to be used for these formals. +-- +-- The following kinds of actuals are passed to various of the formal +-- types listed above: +-- +-- - Undiscriminated type +-- - Type with defaulted discriminants +-- - Type with undefaulted discriminants +-- - Class-wide type +-- +-- A typical usage of S'Definite might be algorithm selection in a +-- generic I/O package, e.g., the use of fixed-length or variable-length +-- records depending on whether the actual is definite or indefinite. +-- In such situations, S'Definite would appear in if conditions or other +-- contexts requiring a boolean expression. This test checks S'Definite +-- in such usage contexts but, for brevity, omits any surrounding +-- usage code. +-- +-- TEST FILES: +-- The following files comprise this test: +-- +-- FC51B00.A +-- -> CC51B03.A +-- +-- +-- CHANGE HISTORY: +-- 06 Dec 94 SAIC ACVC 2.0 +-- +--! + +with FC51B00; -- Indefinite subtype declarations. +package CC51B03_0 is + + -- + -- Formal private type cases: + -- + + generic + type Formal (<>) is private; -- Formal has unknown + package PrivateFormalUnknownDiscriminants is -- discriminant part. + function Is_Definite return Boolean; + end PrivateFormalUnknownDiscriminants; + + + -- + -- Formal derived type cases: + -- + + generic + type Formal (<>) is new FC51B00.Vector -- Formal has an unknown disc. + with private; -- part; ancestor is tagged. + package TaggedAncestorUnknownDiscriminants is + function Is_Definite return Boolean; + end TaggedAncestorUnknownDiscriminants; + + +end CC51B03_0; + + + --==================================================================-- + + +package body CC51B03_0 is + + package body PrivateFormalUnknownDiscriminants is + function Is_Definite return Boolean is + begin + if Formal'Definite then -- Attribute used in "if" + -- ...Execute algorithm #1... -- condition inside subprogram. + return True; + else + -- ...Execute algorithm #2... + return False; + end if; + end Is_Definite; + end PrivateFormalUnknownDiscriminants; + + + package body TaggedAncestorUnknownDiscriminants is + function Is_Definite return Boolean is + begin + return Formal'Definite; -- Attribute used in return + end Is_Definite; -- statement inside subprogram. + end TaggedAncestorUnknownDiscriminants; + + +end CC51B03_0; + + + --==================================================================-- + + +with FC51B00; +package CC51B03_1 is + + subtype Spin_Type is Natural range 0 .. 3; + + type Extended_Vector (Spin : Spin_Type) is -- Tagged type with + new FC51B00.Vector with null record; -- discriminant (indefinite). + + +end CC51B03_1; + + + --==================================================================-- + + +with FC51B00; -- Indefinite subtype declarations. +with CC51B03_0; -- Generic package declarations. +with CC51B03_1; + +with Report; +procedure CC51B03 is + + -- + -- Instances for formal private type with unknown discriminants: + -- + + package PrivateFormal_UndiscriminatedTaggedActual is new + CC51B03_0.PrivateFormalUnknownDiscriminants (FC51B00.Vector); + + package PrivateFormal_ClassWideActual is new + CC51B03_0.PrivateFormalUnknownDiscriminants (FC51B00.Vector'Class); + + package PrivateFormal_DiscriminatedTaggedActual is new + CC51B03_0.PrivateFormalUnknownDiscriminants (FC51B00.Square_Pair); + + package PrivateFormal_DiscriminatedUndefaultedRecordActual is new + CC51B03_0.PrivateFormalUnknownDiscriminants (FC51B00.Square); + + + subtype Length is Natural range 0 .. 20; + type Message (Len : Length := 0) is record -- Record type with defaulted + Text : String (1 .. Len); -- discriminant (definite). + end record; + + package PrivateFormal_DiscriminatedDefaultedRecordActual is new + CC51B03_0.PrivateFormalUnknownDiscriminants (Message); + + + -- + -- Instances for formal derived tagged type with unknown discriminants: + -- + + package DerivedFormal_UndiscriminatedTaggedActual is new + CC51B03_0.TaggedAncestorUnknownDiscriminants (FC51B00.Vector); + + package DerivedFormal_ClassWideActual is new + CC51B03_0.TaggedAncestorUnknownDiscriminants (FC51B00.Vector'Class); + + package DerivedFormal_DiscriminatedTaggedActual is new + CC51B03_0.TaggedAncestorUnknownDiscriminants (CC51B03_1.Extended_Vector); + + +begin + Report.Test ("CC51B03", "Check that S'Definite returns true if the " & + "actual corresponding to S is definite, and false otherwise"); + + + if not PrivateFormal_UndiscriminatedTaggedActual.Is_Definite then + Report.Failed ("Formal private/unknown discriminants: wrong " & + "result for undiscriminated tagged actual"); + end if; + + if PrivateFormal_ClassWideActual.Is_Definite then + Report.Failed ("Formal private/unknown discriminants: wrong " & + "result for class-wide actual"); + end if; + + if PrivateFormal_DiscriminatedTaggedActual.Is_Definite then + Report.Failed ("Formal private/unknown discriminants: wrong " & + "result for discriminated tagged actual"); + end if; + + if PrivateFormal_DiscriminatedUndefaultedRecordActual.Is_Definite then + Report.Failed ("Formal private/unknown discriminants: wrong result " & + "for record actual with undefaulted discriminants"); + end if; + + if not PrivateFormal_DiscriminatedDefaultedRecordActual.Is_Definite then + Report.Failed ("Formal private/unknown discriminants: wrong result " & + "for record actual with defaulted discriminants"); + end if; + + + if not DerivedFormal_UndiscriminatedTaggedActual.Is_Definite then + Report.Failed ("Formal derived/unknown discriminants: wrong result " & + "for undiscriminated tagged actual"); + end if; + + if DerivedFormal_ClassWideActual.Is_Definite then + Report.Failed ("Formal derived/unknown discriminants: wrong result " & + "for class-wide actual"); + end if; + + if DerivedFormal_DiscriminatedTaggedActual.Is_Definite then + Report.Failed ("Formal derived/unknown discriminants: wrong result " & + "for discriminated tagged actual"); + end if; + + + Report.Result; +end CC51B03; diff --git a/gcc/testsuite/ada/acats/tests/cc/cc51d01.a b/gcc/testsuite/ada/acats/tests/cc/cc51d01.a new file mode 100644 index 000000000..63c68c0d4 --- /dev/null +++ b/gcc/testsuite/ada/acats/tests/cc/cc51d01.a @@ -0,0 +1,262 @@ +-- CC51D01.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, in an instance, each implicit declaration of a user-defined +-- subprogram of a formal private extension declares a view of the +-- corresponding primitive subprogram of the ancestor, and that if the +-- tag in a call is statically determined to be that of the formal type, +-- the body executed will be that corresponding to the actual type. +-- +-- Check subprograms declared within a generic formal package. Check for +-- the case where the actual type passed to the formal private extension +-- is a specific tagged type. Check for several types in the same class. +-- +-- +-- TEST DESCRIPTION: +-- Declare a list abstraction in a generic package which manages lists of +-- elements of any nonlimited type (foundation code). Declare a package +-- which declares a tagged type and a type derived from it. Declare an +-- operation for the root tagged type and override it for the derived +-- type. Derive a type from this derived type, but do not override the +-- operation. Declare a generic subprogram which operates on lists of +-- elements of tagged types. Provide the generic subprogram with two +-- formal parameters: (1) a formal derived tagged type which represents a +-- list element type, and (2) a generic formal package with the list +-- abstraction package as template. Use the formal derived type as the +-- generic formal actual part for the formal package. Within the generic +-- subprogram, call the operation of the root tagged type. In the main +-- program, instantiate the generic list package and the generic +-- subprogram with the root tagged type and each derivative, then call +-- each instance with an object of the appropriate type. +-- +-- TEST FILES: +-- The following files comprise this test: +-- +-- FC51D00.A +-- -> CC51D01.A +-- +-- +-- CHANGE HISTORY: +-- 06 Dec 94 SAIC ACVC 2.0 +-- 04 Jan 95 SAIC Moved declaration of type Ranked_ID_Type from +-- main subprogram to package CC51D01_0. Removed +-- case passing class-wide actual to instance. +-- Updated test description and modified comments. +-- +--! + +package CC51D01_0 is -- This package simulates support for a personnel + -- database. + + type SSN_Type is new String (1 .. 9); + + type Blind_ID_Type is tagged record -- Root type of + SSN : SSN_Type; -- class. + -- ... Other components. + end record; + + procedure Update_ID (Item : in out Blind_ID_Type); -- Parent operation. + + -- ... Other operations. + + + type Name_Type is new String (1 .. 9); + + type Named_ID_Type is new Blind_ID_Type with record -- Direct derivative + Name : Name_Type := "Doe "; -- of root type. + -- ... Other components. + end record; + + -- Inherits Update_ID from parent. + + procedure Update_ID (Item : in out Named_ID_Type); -- Overrides parent's + -- implementation. + + + type Ranked_ID_Type is new Named_ID_Type with record + Level : Integer := 0; -- Indirect derivative + -- ... Other components. -- of root type. + end record; + + -- Inherits Update_ID from parent. + +end CC51D01_0; + + + --==================================================================-- + + +package body CC51D01_0 is + + -- The implementations of Update_ID are purely artificial; the validity of + -- their implementations in the context of the abstraction is irrelevant to + -- the feature being tested. + + procedure Update_ID (Item : in out Blind_ID_Type) is + begin + Item.SSN := "111223333"; + end Update_ID; + + + procedure Update_ID (Item : in out Named_ID_Type) is + begin + Item.SSN := "444556666"; + -- ... Other stuff. + end Update_ID; + +end CC51D01_0; + + + --==================================================================-- + + +-- -- +-- Formal package used here. -- +-- -- + +with FC51D00; -- Generic list abstraction. +with CC51D01_0; -- Tagged type declarations. +generic -- This procedure simulates a generic operation for types + -- in the class rooted at Blind_ID_Type. + type Elem_Type is new CC51D01_0.Blind_ID_Type with private; + with package List_Mgr is new FC51D00 (Elem_Type); +procedure CC51D01_1 (L : in out List_Mgr.List_Type; E : in Elem_Type); + + + --==================================================================-- + + +-- The implementation of CC51D01_1 is purely artificial; the validity +-- of its implementation in the context of the abstraction is irrelevant +-- to the feature being tested. +-- +-- The expected behavior here is as follows: for each actual type corresponding +-- to Elem_Type, the call to Update_ID should invoke the actual type's +-- implementation, which updates the object's SSN field. Write_Element then +-- adds the object to the list. + +procedure CC51D01_1 (L : in out List_Mgr.List_Type; E : in Elem_Type) is + Element : Elem_Type := E; -- Can't update IN parameter. +begin + Update_ID (Element); -- Executes actual type's version. + List_Mgr.Write_Element (1, L, Element); -- Executes actual type's version. +end CC51D01_1; + + + --==================================================================-- + + +with FC51D00; -- Generic list abstraction. +with CC51D01_0; -- Tagged type declarations. +with CC51D01_1; -- Generic operation. + +with Report; +procedure CC51D01 is + + use CC51D01_0; -- All types & ops + -- directly visible. + + -- Begin test code declarations: ----------------------- + + TC_Expected_1 : Blind_ID_Type := (SSN => "111223333"); + TC_Expected_2 : Named_ID_Type := ("444556666", "Doe "); + TC_Expected_3 : Ranked_ID_Type := ("444556666", "Doe ", 0); + + TC_Initial_1 : Blind_ID_Type := (SSN => "777889999"); + TC_Initial_2 : Named_ID_Type := ("777889999", "Doe "); + TC_Initial_3 : Ranked_ID_Type := ("777889999", "Doe ", 0); + + -- End test code declarations. ------------------------- + + + -- Begin instantiations and list declarations: --------- + + -- At this point in an application, the generic list package would be + -- instantiated for one of the visible tagged types. Next, the generic + -- subprogram would be instantiated for the same tagged type and the + -- preceding list package instance. + -- + -- In order to cover all the important cases, this test instantiates several + -- packages and subprograms (probably more than would typically appear + -- in user code). + + -- Support for lists of blind IDs: + + package Blind_Lists is new FC51D00 (Blind_ID_Type); + procedure Update_and_Write is new CC51D01_1 (Blind_ID_Type, Blind_Lists); + Blind_List : Blind_Lists.List_Type; + + + -- Support for lists of named IDs: + + package Named_Lists is new FC51D00 (Named_ID_Type); + procedure Update_and_Write is new -- Overloads subprog + CC51D01_1 (Elem_Type => Named_ID_Type, -- for Blind_ID_Type. + List_Mgr => Named_Lists); + Named_List : Named_Lists.List_Type; + + + -- Support for lists of ranked IDs: + + package Ranked_Lists is new FC51D00 (Ranked_ID_Type); + procedure Update_and_Write is new -- Overloads. + CC51D01_1 (Elem_Type => Ranked_ID_Type, + List_Mgr => Ranked_Lists); + Ranked_List : Ranked_Lists.List_Type; + + -- End instantiations and list declarations. ----------- + + +begin + Report.Test ("CC51D01", "Formal private extension, specific tagged " & + "type actual: body of primitive subprogram executed is " & + "that of actual type. Check for subprograms declared in " & + "a formal package"); + + + Update_and_Write (Blind_List, TC_Initial_1); + + if (Blind_Lists.View_Element (1, Blind_List) /= TC_Expected_1) then + Report.Failed ("Wrong result for root tagged type"); + end if; + + + Update_and_Write (Named_List, TC_Initial_2); + + if (Named_Lists.View_Element (1, Named_List) /= TC_Expected_2) then + Report.Failed ("Wrong result for type derived directly from root"); + end if; + + + Update_and_Write (Ranked_List, TC_Initial_3); + + if (Ranked_Lists.View_Element (1, Ranked_List) /= TC_Expected_3) then + Report.Failed ("Wrong result for type derived indirectly from root"); + end if; + + + Report.Result; +end CC51D01; diff --git a/gcc/testsuite/ada/acats/tests/cc/cc51d02.a b/gcc/testsuite/ada/acats/tests/cc/cc51d02.a new file mode 100644 index 000000000..520556391 --- /dev/null +++ b/gcc/testsuite/ada/acats/tests/cc/cc51d02.a @@ -0,0 +1,244 @@ +-- CC51D02.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, in an instance, each implicit declaration of a user-defined +-- subprogram of a formal private extension declares a view of the +-- corresponding primitive subprogram of the ancestor, and that if the +-- tag in a call is statically determined to be that of the formal type, +-- the body executed will be that corresponding to the actual type. +-- +-- Check subprograms declared within a generic formal package. Check for +-- the case where the actual type passed to the formal private extension +-- is a class-wide type. Check for several types in the same class. +-- +-- +-- TEST DESCRIPTION: +-- Declare a list abstraction in a generic package which manages lists of +-- elements of any nonlimited type (foundation code). Declare a package +-- which declares a tagged type and a derivative. Declare an operation +-- for the root tagged type and override it for the derivative. Declare +-- a generic subprogram which operates on lists of elements of tagged +-- types. Provide the generic subprogram with two formal parameters: (1) +-- a formal derived tagged type which represents a list element type, and +-- (2) a generic formal package with the list abstraction package as +-- template. Use the formal derived type as the generic formal actual +-- part for the formal package. Within the generic subprogram, call the +-- operation of the root tagged type. In the main program, instantiate +-- the generic list package and the generic subprogram with the class-wide +-- type for the root tagged type. +-- +-- TEST FILES: +-- The following files comprise this test: +-- +-- FC51D00.A +-- -> CC51D02.A +-- +-- +-- CHANGE HISTORY: +-- 06 Dec 94 SAIC ACVC 2.0 +-- 05 Jan 95 SAIC Changed types of TC_Expected_1 and TC_Expected_2 +-- from specific to class-wide. Eliminated (illegal) +-- assignment step prior to comparison of +-- TC_Expected_X with item on stack. +-- +--! + +package CC51D02_0 is -- This package simulates support for a personnel + -- database. + + type SSN_Type is new String (1 .. 9); + + type Blind_ID_Type is tagged record -- Root type of + SSN : SSN_Type; -- class. + -- ... Other components. + end record; + + procedure Update_ID (Item : in out Blind_ID_Type); -- Parent operation. + + -- ... Other operations. + + + type Name_Type is new String (1 .. 9); + + type Named_ID_Type is new Blind_ID_Type with record -- Direct derivative + Name : Name_Type := "Doe "; -- of root type. + -- ... Other components. + end record; + + -- Inherits Update_ID from parent. + + procedure Update_ID (Item : in out Named_ID_Type); -- Overrides parent's + -- implementation. + +end CC51D02_0; + + + --==================================================================-- + + +package body CC51D02_0 is + + -- The implementations of Update_ID are purely artificial; the validity of + -- their implementations in the context of the abstraction is irrelevant to + -- the feature being tested. + + procedure Update_ID (Item : in out Blind_ID_Type) is + begin + Item.SSN := "111223333"; + end Update_ID; + + + procedure Update_ID (Item : in out Named_ID_Type) is + begin + Item.SSN := "444556666"; + -- ... Other stuff. + end Update_ID; + +end CC51D02_0; + + + --==================================================================-- + + +-- -- +-- Formal package used here. -- +-- -- + +with FC51D00; -- Generic list abstraction. +with CC51D02_0; -- Tagged type declarations. +generic -- This procedure simulates a generic operation for types + -- in the class rooted at Blind_ID_Type. + type Elem_Type (<>) is new CC51D02_0.Blind_ID_Type with private; + with package List_Mgr is new FC51D00 (Elem_Type); +procedure CC51D02_1 (L : in out List_Mgr.List_Type; E : in Elem_Type); + + + --==================================================================-- + + +-- The implementation of CC51D02_1 is purely artificial; the validity +-- of its implementation in the context of the abstraction is irrelevant +-- to the feature being tested. +-- +-- The expected behavior here is as follows: for each actual type corresponding +-- to Elem_Type, the call to Update_ID should invoke the actual type's +-- implementation (based on the tag of the actual), which updates the object's +-- SSN field. Write_Element then adds the object to the list. + +procedure CC51D02_1 (L : in out List_Mgr.List_Type; E : in Elem_Type) is + Element : Elem_Type := E; -- Can't update IN parameter. + -- Initialization of unconstrained variable. +begin + Update_ID (Element); -- Executes actual type's version + -- (for this test, this will be a + -- dispatching call). + List_Mgr.Write_Element (1, L, Element); -- Executes actual type's version + -- (for this test, this will be a + -- class-wide operation). +end CC51D02_1; + + + --==================================================================-- + + +with FC51D00; -- Generic list abstraction. +with CC51D02_0; -- Tagged type declarations. +with CC51D02_1; -- Generic operation. + +with Report; +procedure CC51D02 is + + use CC51D02_0; -- All types & ops + -- directly visible. + + -- Begin test code declarations: ----------------------- + + TC_Expected_1 : Blind_ID_Type'Class := + Blind_ID_Type'(SSN => "111223333"); + TC_Expected_2 : Blind_ID_Type'Class := + Named_ID_Type'("444556666", "Doe "); + + + TC_Initial_1 : Blind_ID_Type := (SSN => "777889999"); + TC_Initial_2 : Named_ID_Type := ("777889999", "Doe "); + TC_Initial_3 : Blind_ID_Type'Class := TC_Initial_2; + + -- End test code declarations. ------------------------- + + + package ID_Class_Lists is new FC51D00 (Blind_ID_Type'Class); + + procedure Update_and_Write is new CC51D02_1 (Blind_ID_Type'Class, + ID_Class_Lists); + + Blind_List : ID_Class_Lists.List_Type; + Named_List : ID_Class_Lists.List_Type; + Maimed_List : ID_Class_Lists.List_Type; + + +begin + Report.Test ("CC51D02", "Formal private extension, class-wide actual: " & + "body of primitive subprogram executed is that of actual " & + "type. Check for subprograms declared in formal package"); + + + Update_and_Write (Blind_List, TC_Initial_1); -- Test root type actual. + + if (ID_Class_Lists.View_Element (1, Blind_List) not in Blind_ID_Type) then + Report.Failed ("Result for root type actual is not in proper class"); + elsif (ID_Class_Lists.View_Element (1, Blind_List) /= TC_Expected_1) then + Report.Failed ("Wrong result for root type actual"); + end if; + + + Update_and_Write (Named_List, TC_Initial_2); -- Test derived type actual. + + if (ID_Class_Lists.View_Element (1, Named_List) not in Named_ID_Type) then + Report.Failed ("Result for derived type actual is not in proper class"); + elsif (ID_Class_Lists.View_Element (1, Named_List)/= TC_Expected_2) then + Report.Failed ("Wrong result for derived type actual"); + end if; + + + -- In the subtest below, an object of a class-wide type (TC_Initial_3) is + -- passed to Update_and_Write. It has been initialized with an object of + -- type Named_ID_Type, so the result should be identical to + -- that of the Named_ID_Type subtest (namely TC_Expected_2). Note that + -- a new list of Named IDs is used (Maimed_List). This is to assure test + -- validity, since Named_List has already been updated by a previous + -- subtest. + + Update_and_Write (Maimed_List, TC_Initial_3); -- Test class-wide actual. + + if (ID_Class_Lists.View_Element (1, Maimed_List) not in Named_ID_Type) then + Report.Failed ("Result for class-wide actual is not in proper class"); + elsif (ID_Class_Lists.View_Element (1, Maimed_List) /= TC_Expected_2) then + Report.Failed ("Wrong result for class-wide actual"); + end if; + + + Report.Result; +end CC51D02; diff --git a/gcc/testsuite/ada/acats/tests/cc/cc54001.a b/gcc/testsuite/ada/acats/tests/cc/cc54001.a new file mode 100644 index 000000000..eb297d0ec --- /dev/null +++ b/gcc/testsuite/ada/acats/tests/cc/cc54001.a @@ -0,0 +1,184 @@ +-- CC54001.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 general access-to-constant type may be passed as an +-- actual to a generic formal access-to-constant type. +-- +-- TEST DESCRIPTION: +-- The generic implements a stack of access objects as an array. The +-- designated type of the formal access type is itself a formal private +-- type declared in the same generic formal part. +-- +-- The generic is instantiated with an unconstrained subtype of String, +-- which results in a stack which can accommodate strings of varying +-- lengths (ragged array). Furthermore, the access objects to be pushed +-- onto the stack are created both statically and dynamically, utilizing +-- allocators and the 'Access attribute. +-- +-- +-- CHANGE HISTORY: +-- 06 Dec 94 SAIC ACVC 2.0 +-- 10 Apr 96 SAIC ACVC 2.1: Added pragma Elaborate to context clause +-- preceding CC54001_1. +-- +--! + +generic + Size : in Positive; + type Element_Type (<>) is private; + type Element_Ptr is access constant Element_Type; +package CC54001_0 is -- Generic stack of pointers. + + type Stack_Type is private; + + procedure Push (Stack : in out Stack_Type; + Elem_Ptr : in Element_Ptr); + + procedure Pop (Stack : in out Stack_Type; + Elem_Ptr : out Element_Ptr); + + -- ... Other operations. + +private + + subtype Index is Positive range 1 .. (Size + 1); + type Stack_Type is array (Index) of Element_Ptr; -- Last element unused. + + Top : Index := 1; + +end CC54001_0; + + + --===================================================================-- + + +package body CC54001_0 is + + procedure Push (Stack : in out Stack_Type; + Elem_Ptr : in Element_Ptr) is + begin + Stack(Top) := Elem_Ptr; + Top := Top + 1; -- Artificial: no Constraint_Error protection. + end Push; + + + procedure Pop (Stack : in out Stack_Type; + Elem_Ptr : out Element_Ptr) is + begin + Top := Top - 1; -- Artificial: no Constraint_Error protection. + Elem_Ptr := Stack(Top); + end Pop; + +end CC54001_0; + + + --===================================================================-- + + +with CC54001_0; -- Generic stack of pointers. +pragma Elaborate (CC54001_0); + +package CC54001_1 is + + subtype Message is String; + type Message_Ptr is access constant Message; + + Message_Count : constant := 4; + + Message_0 : aliased constant Message := "Hello"; + Message_1 : aliased constant Message := "Doctor"; + Message_2 : aliased constant Message := "Name"; + Message_3 : aliased constant Message := "Continue"; + + + package Stack_of_Messages is new CC54001_0 + (Element_Type => Message, + Element_Ptr => Message_Ptr, + Size => Message_Count); + + Message_Stack : Stack_Of_Messages.Stack_Type; + + + procedure Create_Message_Stack; + +end CC54001_1; + + + --===================================================================-- + + +package body CC54001_1 is + + procedure Create_Message_Stack is + -- Push access objects onto stack. Note that some are statically + -- allocated, and some are dynamically allocated (using an aliased + -- object to initialize). + begin + Stack_Of_Messages.Push (Message_Stack, Message_0'Access); -- Static. + Stack_Of_Messages.Push (Message_Stack, + new Message'(Message_1)); -- Dynamic. + Stack_Of_Messages.Push (Message_Stack, Message_2'Access); -- Static. + Stack_Of_Messages.Push (Message_Stack, -- Dynamic. + new Message'(Message_3)); + end Create_Message_Stack; + +end CC54001_1; + + + --===================================================================-- + + +with CC54001_1; + +with Report; +procedure CC54001 is + + package Messages renames CC54001_1.Stack_Of_Messages; + + Msg0, Msg1, Msg2, Msg3 : CC54001_1.Message_Ptr; + +begin + Report.Test ("CC54001", "Check that a general access-to-constant type " & + "may be passed as an actual to a generic formal " & + "access-to-constant type"); + + CC54001_1.Create_Message_Stack; + + Messages.Pop (CC54001_1.Message_Stack, Msg3); -- Pop items off stack in the + Messages.Pop (CC54001_1.Message_Stack, Msg2); -- reverse order that they + Messages.Pop (CC54001_1.Message_Stack, Msg1); -- were pushed. + Messages.Pop (CC54001_1.Message_Stack, Msg0); + + if Msg0.all /= CC54001_1.Message_0 or else + Msg1.all /= CC54001_1.Message_1 or else + Msg2.all /= CC54001_1.Message_2 or else + Msg3.all /= CC54001_1.Message_3 + then + Report.Failed ("Items popped off of stack do not match those pushed"); + end if; + + Report.Result; +end CC54001; diff --git a/gcc/testsuite/ada/acats/tests/cc/cc54002.a b/gcc/testsuite/ada/acats/tests/cc/cc54002.a new file mode 100644 index 000000000..623f25d6c --- /dev/null +++ b/gcc/testsuite/ada/acats/tests/cc/cc54002.a @@ -0,0 +1,223 @@ +-- CC54002.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 general access-to-variable type may be passed as an +-- actual to a generic formal general access-to-variable type. Check that +-- designated objects may be read and updated through the access value. +-- +-- TEST DESCRIPTION: +-- The generic implements a List of access objects as an array, which +-- is itself a component of a record. The designated type of the formal +-- access type is a formal private type declared in the same generic +-- formal part. +-- +-- The access objects to be placed in the List are created both +-- statically and dynamically, utilizing allocators and the 'Access +-- attribute. +-- +-- +-- CHANGE HISTORY: +-- 06 Dec 94 SAIC ACVC 2.0 +-- 10 Apr 96 SAIC ACVC 2.1: Added pragma Elaborate to context clause +-- preceding CC54002_1. +-- +--! + +generic + Size : in Positive; + type Element_Type (<>) is private; + type Element_Ptr is access all Element_Type; +package CC54002_0 is -- Generic list of pointers. + + subtype Index is Positive range 1 .. (Size + 1); + + type List_Array is array (Index) of Element_Ptr; + + type List_Type is record + Elements : List_Array; + Next : Index := 1; -- Next available "slot" in list. + end record; + + + procedure Put (List : in out List_Type; + Elem_Ptr : in Element_Ptr; + Location : in Index); + + procedure Get (List : in out List_Type; + Elem_Ptr : out Element_Ptr; + Location : in Index); + + -- ... Other operations. + +end CC54002_0; + + + --===================================================================-- + + +package body CC54002_0 is + + procedure Put (List : in out List_Type; + Elem_Ptr : in Element_Ptr; + Location : in Index) is + begin + List.Elements(Location) := Elem_Ptr; + end Put; + + + procedure Get (List : in out List_Type; + Elem_Ptr : out Element_Ptr; + Location : in Index) is + begin -- Artificial: no provision for getting "empty" element. + Elem_Ptr := List.Elements(Location); + end Get; + +end CC54002_0; + + + --===================================================================-- + + +with CC54002_0; -- Generic List of pointers. +pragma Elaborate (CC54002_0); + +package CC54002_1 is + + subtype Lengths is Natural range 0 .. 50; + + type Subscriber (NLen, ALen: Lengths := 50) is record + Name : String(1 .. NLen); + Address : String(1 .. ALen); + -- ... Other components. + end record; + + type Subscriber_Ptr is access all Subscriber; -- General access-to- + -- variable type. + + package District_Subscription_Lists is new CC54002_0 + (Element_Type => Subscriber, + Element_Ptr => Subscriber_Ptr, + Size => 100); + + District_01_Subscribers : District_Subscription_Lists.List_Type; + + + New_Subscriber_01 : aliased CC54002_1.Subscriber := + (12, 23, "Brown, Silas", "King's Pyland, Dartmoor"); + + New_Subscriber_02 : aliased CC54002_1.Subscriber := + (16, 23, "Hatherly, Victor", "16A Victoria St. London"); + +end CC54002_1; + +-- No body for CC54002_1. + + + --===================================================================-- + + +with CC54002_1; + +with Report; +procedure CC54002 is + + Mod_Subscriber_01 : constant CC54002_1.Subscriber := + (12, 23, "Brown, Silas", "Mapleton, Dartmoor "); + + TC_Actual_01, TC_Actual_02 : CC54002_1.Subscriber_Ptr; + + + use type CC54002_1.Subscriber; -- "/=" directly visible. + +begin + Report.Test ("CC54002", "Check that a general access-to-variable type " & + "may be passed as an actual to a generic formal " & + "access-to-variable type"); + + + -- Add elements to the list: + + CC54002_1.District_Subscription_Lists.Put -- Element created statically. + (List => CC54002_1.District_01_Subscribers, + Elem_Ptr => CC54002_1.New_Subscriber_01'Access, + Location => 1); + + CC54002_1.District_Subscription_Lists.Put -- Element created dynamically. + (List => CC54002_1.District_01_Subscribers, + Elem_Ptr => new CC54002_1.Subscriber'(CC54002_1.New_Subscriber_02), + Location => 2); + + + -- Manipulation of the objects on the list is performed below directly + -- through the access objects. Although such manipulation is artificial + -- from the perspective of this usage model, it is not artificial in + -- general and is necessary in order to test the objective. + + + -- Modify the first list element through the access object: + + CC54002_1.District_01_Subscribers.Elements(1).Address := -- Update + "Mapleton, Dartmoor "; -- Implicit dereference. -- through the + -- access + -- object. + -- Retrieve elements of the list: + + CC54002_1.District_Subscription_Lists.Get + (CC54002_1.District_01_Subscribers, + TC_Actual_01, + 1); + + CC54002_1.District_Subscription_Lists.Get + (CC54002_1.District_01_Subscribers, + TC_Actual_02, + 2); + + -- Verify list contents in two ways: 1st verify the directly-dereferenced + -- access objects against the dereferenced access objects returned by Get; + -- 2nd verify them against objects the expected values: + + -- Read + -- through the + -- access + -- objects. + + if CC54002_1.District_01_Subscribers.Elements(1).all /= TC_Actual_01.all + or else + CC54002_1.District_01_Subscribers.Elements(2).all /= TC_Actual_02.all + then + Report.Failed ("Wrong results returned by Get"); + + elsif CC54002_1.District_01_Subscribers.Elements(1).all /= + Mod_Subscriber_01 + or + CC54002_1.District_01_Subscribers.Elements(2).all /= + CC54002_1.New_Subscriber_02 + then + Report.Failed ("List elements do not have expected values"); + end if; + + Report.Result; +end CC54002; diff --git a/gcc/testsuite/ada/acats/tests/cc/cc54003.a b/gcc/testsuite/ada/acats/tests/cc/cc54003.a new file mode 100644 index 000000000..d8aaeaf9c --- /dev/null +++ b/gcc/testsuite/ada/acats/tests/cc/cc54003.a @@ -0,0 +1,234 @@ +-- CC54003.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 general access-to-subprogram type may be passed as an +-- actual to a generic formal access-to-subprogram type. Check that +-- designated subprograms may be called by dereferencing the access +-- values. +-- +-- TEST DESCRIPTION: +-- The generic implements a stack of access-to-subprogram objects as an +-- array. The profile of the access-to-subprogram formal corresponds to +-- a function which accepts a parameter of some type and returns an +-- object of the same type. +-- +-- For this test, the functions for which access values will be pushed +-- onto the stack accept a parameter of type access-to-string, lengthen +-- the pointed-to string, then return an access object pointing to this +-- lengthened string. +-- +-- The instance declares a function Execute_Stack which executes each +-- subprogram on the stack in sequence. This function accepts some initial +-- access-to-string, then returns an access object pointing to the +-- lengthened string resulting from the execution of the stacked +-- subprograms. Access-to-string objects are used rather than strings +-- themselves because the initial string "grows" during each iteration. +-- +-- +-- CHANGE HISTORY: +-- 06 Dec 94 SAIC ACVC 2.0 +-- 10 Apr 96 SAIC ACVC 2.1: Added pragma Elaborate to context clause +-- preceding CC54003_2. +-- +--! + +generic + + Size : in Positive; + + type Item_Type (<>) is private; + type Item_Ptr is access Item_Type; + + type Function_Ptr is access function (Item : Item_Ptr) + return Item_Ptr; + +package CC54003_0 is -- Generic stack of pointers. + + type Stack_Type is private; + + procedure Push (Stack : in out Stack_Type; + Func_Ptr : in Function_Ptr); + + function Execute_Stack (Stack : Stack_Type; + Initial_Input : Item_Ptr) return Item_Ptr; + + -- ... Other operations. + +private + + subtype Index is Positive range 1 .. (Size + 1); + type Stack_Type is array (Index) of Function_Ptr; -- Last slot unused. + + Top : Index := 1; -- Top refers to the next available slot. + +end CC54003_0; + + + --===================================================================-- + + +package body CC54003_0 is + + procedure Push (Stack : in out Stack_Type; + Func_Ptr : in Function_Ptr) is + begin + Stack(Top) := Func_Ptr; + Top := Top + 1; -- Artificial: no Constraint_Error protection. + end Push; + + + -- Call each subprogram on the stack in sequence. For the first call, pass + -- Initial_Input. For succeeding calls, pass the result of the previous + -- call. + + function Execute_Stack (Stack : Stack_Type; + Initial_Input : Item_Ptr) return Item_Ptr is + Result : Item_Ptr := Initial_Input; + begin + for I in reverse Index'First .. (Top - 1) loop -- Artificial: no C_E + Result := Stack(I)(Result); -- protection. + end loop; + return Result; + end Execute_Stack; + +end CC54003_0; + + + --===================================================================-- + + +package CC54003_1 is + + subtype Message is String; + type Message_Ptr is access Message; + + function Add_Prefix (Msg_Ptr : Message_Ptr) return Message_Ptr; + function Add_Suffix (Msg_Ptr : Message_Ptr) return Message_Ptr; + + -- ...Other operations. + +end CC54003_1; + + + --===================================================================-- + + +package body CC54003_1 is + + function Add_Prefix (Msg_Ptr : Message_Ptr) return Message_Ptr is + Sender : constant String := "Dummy: "; -- Artificial; in a real + -- application Sender might + New_Msg : Message := Sender & Msg_Ptr.all; -- be a call to a function. + begin + return new Message'(New_Msg); + end Add_Prefix; + + + function Add_Suffix (Msg_Ptr : Message_Ptr) return Message_Ptr is + Time : constant String := " (12:03pm)"; -- Artificial; in a real + -- application Time might be a + New_Msg : Message := Msg_Ptr.all & Time; -- be a call to a function. + begin + return new Message'(New_Msg); + end Add_Suffix; + +end CC54003_1; + + + --===================================================================-- + + +with CC54003_0; -- Generic stack of pointers. +pragma Elaborate (CC54003_0); + +with CC54003_1; -- Message abstraction. + +package CC54003_2 is + + type Operation_Ptr is access function (Msg_Ptr : CC54003_1.Message_Ptr) + return CC54003_1.Message_Ptr; + + Maximum_Ops : constant := 4; -- Arbitrary. + + package Stack_of_Ops is new CC54003_0 + (Item_Type => CC54003_1.Message, + Item_Ptr => CC54003_1.Message_Ptr, + Function_Ptr => Operation_Ptr, + Size => Maximum_Ops); + + Operation_Stack : Stack_Of_Ops.Stack_Type; + + + procedure Create_Operation_Stack; + +end CC54003_2; + + --===================================================================-- + + +package body CC54003_2 is + + procedure Create_Operation_Stack is + begin + Stack_Of_Ops.Push (Operation_Stack, CC54003_1.Add_Prefix'Access); + Stack_Of_Ops.Push (Operation_Stack, CC54003_1.Add_Suffix'Access); + end Create_Operation_Stack; + +end CC54003_2; + + + --===================================================================-- + + +with CC54003_1; -- Message abstraction. +with CC54003_2; -- Message-operation stack. + +with Report; +procedure CC54003 is + + package Msg_Ops renames CC54003_2.Stack_Of_Ops; + + Msg : CC54003_1.Message_Ptr := new CC54003_1.Message'("Hello there"); + Expected : CC54003_1.Message := "Dummy: Hello there (12:03pm)"; + +begin + Report.Test ("CC54003", "Check that a general access-to-subprogram type " & + "may be passed as an actual to a generic formal " & + "access-to-subprogram type"); + + CC54003_2.Create_Operation_Stack; + + declare + Actual : CC54003_1.Message_Ptr := + Msg_Ops.Execute_Stack (CC54003_2.Operation_Stack, Msg); + begin + if Actual.all /= Expected then + Report.Failed ("Wrong result from dereferenced subprogram execution"); + end if; + end; + + Report.Result; +end CC54003; diff --git a/gcc/testsuite/ada/acats/tests/cc/cc54004.a b/gcc/testsuite/ada/acats/tests/cc/cc54004.a new file mode 100644 index 000000000..0023b3a74 --- /dev/null +++ b/gcc/testsuite/ada/acats/tests/cc/cc54004.a @@ -0,0 +1,295 @@ +-- CC54004.A +-- +-- Grant of Unlimited Rights +-- +-- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687, +-- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained +-- unlimited rights in the software and documentation contained herein. +-- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making +-- this public release, the Government intends to confer upon all +-- recipients unlimited rights equal to those held by the Government. +-- These rights include rights to use, duplicate, release or disclose the +-- released technical data and computer software in whole or in part, in +-- any manner and for any purpose whatsoever, and to have or permit others +-- to do so. +-- +-- DISCLAIMER +-- +-- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR +-- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED +-- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE +-- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE +-- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A +-- PARTICULAR PURPOSE OF SAID MATERIAL. +--* +-- +-- OBJECTIVE: +-- Check that the designated type of a generic formal pool-specific +-- access type may be class-wide. Check that calls to primitive +-- subprograms in the instance dispatch to the appropriate bodies when +-- the controlling operand is a dereference of an object of the access- +-- to-class-wide type. +-- +-- TEST DESCRIPTION: +-- A hierarchy of types is declared in two packages. The root type of +-- the class is declared as abstract in a separate package. It possesses +-- an abstract primitive subprogram Handle. A concrete type extends the +-- root type in a second package with a component of an enumeration type. +-- A second type extends this extension in the same package. Both +-- derivatives override the root type's primitive subprogram with a +-- non-abstract subprogram. +-- +-- The generic implements a heterogeneous stack of access-to-class-wide +-- objects in the root type's class. A subprogram declared in the +-- generic calls Handle using dereferences of each of the class-wide +-- objects on the stack as operand. Each call to Handle should dispatch +-- to the appropriate body based on the tag of the operand. The +-- overriding versions of Handle each set the component of the type to +-- a different value. The value of the component is checked to verify +-- that the calls dispatched correctly. +-- +-- +-- CHANGE HISTORY: +-- 06 Dec 94 SAIC ACVC 2.0 +-- 10 Apr 96 SAIC ACVC 2.1: Added pragma Elaborate to context clause +-- preceding CC54004_3. +-- +--! + +package CC54004_0 is + + -- The types and operations defined here are artificial. The component + -- TC_Code is the only component required for testing purposes. + + type TC_Code_Type is (None, Low, Medium); + + type Alert is abstract tagged record -- Abstract type. + TC_Code : TC_Code_Type; -- Testing flag. + end record; + + procedure Handle (A : in out Alert); -- Non-abstract primitive + -- subprogram. + -- ...Other operations. + + type Alert_Ptr is access Alert'Class; -- Access-to-class-wide + -- type. +end CC54004_0; + + + --===================================================================-- + + +package body CC54004_0 is + + procedure Handle (A : in out Alert) is + begin + A.TC_Code := None; + end Handle; + +end CC54004_0; + + + --===================================================================-- + + +with CC54004_0; +use CC54004_0; +package CC54004_1 is + + type Low_Alert is new CC54004_0.Alert with record + C1 : String (1 .. 5) := "Dummy"; + -- ...Other components. + end record; + + procedure Handle (A : in out Low_Alert); -- Overrides parent's + -- operations. + --...Other operations. + + + type Medium_Alert is new Low_Alert with record + C : Integer := 6; + -- ...Other components. + end record; + + procedure Handle (A : in out Medium_Alert); -- Overrides parent's + -- operations. + --...Other operations. + +end CC54004_1; + + + --===================================================================-- + +package body CC54004_1 is + + procedure Handle (A : in out Low_Alert) is + begin + A.TC_Code := Low; + end Handle; + + procedure Handle (A : in out Medium_Alert) is + begin + A.TC_Code := Medium; + end Handle; + +end CC54004_1; + + + --===================================================================-- + + +with CC54004_0; +generic + type Element_Type is abstract new CC54004_0.Alert with private; + type Element_Ptr is access Element_Type'Class; +package CC54004_2 is + + type Stack_Type is private; + + procedure Push (Stack : in out Stack_Type; + Elem_Ptr : in Element_Ptr); + + procedure Pop (Stack : in out Stack_Type; + Elem_Ptr : out Element_Ptr); + + procedure Process_Stack (Stack : in out Stack_Type); + + -- ... Other operations. + +private + + subtype Index is Positive range 1 .. 5; + type Stack_Type is array (Index) of Element_Ptr; + + Top : Index := 1; + +end CC54004_2; + + + --===================================================================-- + + +package body CC54004_2 is + + procedure Push (Stack : in out Stack_Type; + Elem_Ptr : in Element_Ptr) is + begin + Stack(Top) := Elem_Ptr; + Top := Top + 1; -- Artificial: no Constraint_Error protection. + end Push; + + + procedure Pop (Stack : in out Stack_Type; + Elem_Ptr : out Element_Ptr)is + begin + Top := Top - 1; -- Artificial: no Constraint_Error protection. + Elem_Ptr := Stack(Top); + end Pop; + + + -- Call Handle for each element on the stack. Since the dereferenced access + -- object is of a class-wide type, all calls to Handle are dispatching. The + -- version of Handle called will be that declared for the type + -- corresponding to the tag of the operand. + + procedure Process_Stack (Stack : in out Stack_Type) is + begin -- Artificial: no Constraint_Error protection. + for I in reverse Index'First .. (Top - 1) loop + Handle (Stack(I).all); -- Call dispatches based on + end loop; -- tag of operand. + end Process_Stack; + +end CC54004_2; + + + --===================================================================-- + + +with CC54004_0; +with CC54004_1; +with CC54004_2; +pragma Elaborate (CC54004_2); + +package CC54004_3 is + + package Alert_Stacks is new CC54004_2 (Element_Type => CC54004_0.Alert, + Element_Ptr => CC54004_0.Alert_Ptr); + + -- All overriding versions of Handle visible at the point of instantiation. + + Alert_List : Alert_Stacks.Stack_Type; + + procedure TC_Create_Alert_Stack; + +end CC54004_3; + + + --===================================================================-- + + +package body CC54004_3 is + + procedure TC_Create_Alert_Stack is + begin + Alert_Stacks.Push (Alert_List, new CC54004_1.Low_Alert); + Alert_Stacks.Push (Alert_List, new CC54004_1.Medium_Alert); + end TC_Create_Alert_Stack; + +end CC54004_3; + + + --===================================================================-- + + +with CC54004_0; +with CC54004_1; +with CC54004_3; + +with Report; +procedure CC54004 is + TC_Low_Ptr, TC_Med_Ptr : CC54004_0.Alert_Ptr; + TC_Low_Actual : CC54004_1.Low_Alert; + TC_Med_Actual : CC54004_1.Medium_Alert; + + use type CC54004_0.TC_Code_Type; +begin + Report.Test ("CC54004", "Check that the designated type of a generic " & + "formal pool-specific access type may be class-wide"); + + + -- Create stack of elements: + + CC54004_3.TC_Create_Alert_Stack; + + + -- Commence dispatching operations on stack elements: + + CC54004_3.Alert_Stacks.Process_Stack (CC54004_3.Alert_List); + + + -- Pop "handled" alerts off stack: + + CC54004_3.Alert_Stacks.Pop (CC54004_3.Alert_List, TC_Med_Ptr); + CC54004_3.Alert_Stacks.Pop (CC54004_3.Alert_List, TC_Low_Ptr); + + + -- Verify results: + + if TC_Low_Ptr.all not in CC54004_1.Low_Alert or else + TC_Med_Ptr.all not in CC54004_1.Medium_Alert + then + Report.Failed ("Class-wide objects do not have expected tags"); + + -- The explicit dereference of the "Pop"ed pointers results in views of + -- the designated objects, the nominal subtypes of which are class-wide. + -- In order to be able to reference the component TC_Code, these views + -- must be converted to a specific type possessing that component. + + elsif CC54004_1.Low_Alert(TC_Low_Ptr.all).TC_Code /= CC54004_0.Low or + CC54004_1.Medium_Alert(TC_Med_Ptr.all).TC_Code /= CC54004_0.Medium + then + Report.Failed ("Calls did not dispatch to expected operations"); + end if; + + Report.Result; +end CC54004; diff --git a/gcc/testsuite/ada/acats/tests/cc/cc70001.a b/gcc/testsuite/ada/acats/tests/cc/cc70001.a new file mode 100644 index 000000000..65681b072 --- /dev/null +++ b/gcc/testsuite/ada/acats/tests/cc/cc70001.a @@ -0,0 +1,309 @@ +-- CC70001.A +-- +-- Grant of Unlimited Rights +-- +-- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687, +-- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained +-- unlimited rights in the software and documentation contained herein. +-- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making +-- this public release, the Government intends to confer upon all +-- recipients unlimited rights equal to those held by the Government. +-- These rights include rights to use, duplicate, release or disclose the +-- released technical data and computer software in whole or in part, in +-- any manner and for any purpose whatsoever, and to have or permit others +-- to do so. +-- +-- DISCLAIMER +-- +-- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR +-- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED +-- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE +-- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE +-- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A +-- PARTICULAR PURPOSE OF SAID MATERIAL. +--* +-- +-- OBJECTIVE: +-- Check that the template for a generic formal package may be a child +-- package, and that a child instance which is an instance of the +-- template may be passed as an actual to the formal package. Check that +-- the visible part of the generic formal package includes the first list +-- of basic declarative items of the package specification. +-- +-- TEST DESCRIPTION: +-- Declare a list abstraction in a generic package which manages lists of +-- elements of any nonlimited type. Declare a generic child package of +-- this package which defines additional list operations. Declare a +-- generic subprogram which operates on lists of elements of discrete +-- types. Provide the generic subprogram with three formal parameters: +-- (1) a formal discrete type which represents a list element type, (2) +-- a generic formal package with the parent list generic as template, and +-- (3) a generic formal package with the child list generic as template. +-- Use the formal discrete type as the generic formal actual part for the +-- parent formal package. In the main program, declare an instance of +-- parent, then declare an instance of the child which is itself a child +-- the parent's instance. Pass these instances as actuals to the generic +-- subprogram instance. +-- +-- +-- CHANGE HISTORY: +-- 06 Dec 94 SAIC ACVC 2.0 +-- 05 Nov 95 SAIC ACVC 2.0.1 fixes: Corrected syntax of formal +-- package declaration. +-- 27 Feb 97 PWB.CTA Added an elaboration pragma. +--! + +generic + type Element_Type is private; -- List elems may be of any nonlimited type. +package CC70001_0 is -- List abstraction. + + type List_Type is limited private; + + + -- Return true if current element is last in the list. + function End_Of_List (L : List_Type) return Boolean; + + -- Set "current" pointer to first list element. + procedure Reset (L : in out List_Type); + +private + + type Node_Type; + type Node_Pointer is access Node_Type; + + type Node_Type is record + Item : Element_Type; + Next : Node_Pointer; + end record; + + type List_Type is record + First : Node_Pointer; + Current : Node_Pointer; + Last : Node_Pointer; + end record; + +end CC70001_0; + + + --==================================================================-- + + +package body CC70001_0 is + + function End_Of_List (L : List_Type) return Boolean is + begin + return (L.Current = null); + end End_Of_List; + + + procedure Reset (L : in out List_Type) is + begin + L.Current := L.First; -- Set "current" pointer to first + end Reset; -- list element. + +end CC70001_0; + + + --==================================================================-- + + +-- Child must be generic since parent is generic. A formal parameter for +-- "element type" can not be provided here, because then the type of list +-- element assumed by these new operations would be different from that +-- defined by the list type declared in the parent. + +generic +package CC70001_0.CC70001_1 is -- Additional list operations. + + -- Read from current element and advance "current" pointer. + procedure Read_Element (L : in out List_Type; E : out Element_Type); + + -- Write to current element and advance "current" pointer. + procedure Write_Element (L : in out List_Type; E : in Element_Type); + + -- Add element to end of list. + procedure Add_Element (L : in out List_Type; E : in Element_Type); + +end CC70001_0.CC70001_1; + + + --==================================================================-- + + +package body CC70001_0.CC70001_1 is + + procedure Read_Element (L : in out List_Type; E : out Element_Type) is + begin + -- ... Error-checking code omitted for brevity. + E := L.Current.Item; -- Retrieve current element. + L.Current := L.Current.Next; -- Advance "current" pointer. + end Read_Element; + + + procedure Write_Element (L : in out List_Type; E : in Element_Type) is + begin + -- ... Error-checking code omitted for brevity. + L.Current.Item := E; -- Write to current element. + L.Current := L.Current.Next; -- Advance "current" pointer. + end Write_Element; + + + procedure Add_Element (L : in out List_Type; E : in Element_Type) is + New_Node : Node_Pointer := new Node_Type'(E, null); + begin + if L.First = null then -- No elements in list, so add new + L.First := New_Node; -- element at beginning of list. + else + L.Last.Next := New_Node; -- Add new element at end of list. + end if; + L.Last := New_Node; -- Set last-in-list pointer. + end Add_Element; + +end CC70001_0.CC70001_1; + + + --==================================================================-- + + +with CC70001_0.CC70001_1; -- Generic list abstraction + additional operations. +generic + + -- Import the list abstraction defined in CC70001_0, as well as the + -- additional operations defined in CC70001_0.CC70001_1. Declare a formal + -- discrete type. Restrict this generic procedure to operate only on lists + -- of discrete elements by passing the formal discrete type as an actual + -- parameter to the formal (parent) package. + + type Elem_Type is (<>); -- Discrete types only. + with package List_Mgr is new CC70001_0 (Elem_Type); + with package List_Ops is new List_Mgr.CC70001_1 (<>); + +procedure CC70001_2 (L : in out List_Mgr.List_Type); + + + --==================================================================-- + + +procedure CC70001_2 (L : in out List_Mgr.List_Type) is +begin + List_Mgr.Reset (L); + while not List_Mgr.End_Of_List (L) loop + List_Ops.Write_Element (L, Elem_Type'First); + end loop; +end CC70001_2; + + + --==================================================================-- + + +package CC70001_3 is + + type Points is range 0 .. 10; + + -- ... Various other types used by the application. + +end CC70001_3; + + +-- No body for CC70001_3; + + + --==================================================================-- + + +-- Declare instances of the generic list packages for the discrete type. +-- In order to establish that the type passed as an actual to the parent +-- generic (CC70001_0) is the one utilized by the child generic (CC70001_1), +-- the instance of the child must itself be declared as a child of the +-- instance of the parent. Since only library units may have or be children, +-- both instances must be library units. + +with CC70001_0; -- Generic list abstraction. +with CC70001_3; -- Package containing discrete type declaration. +pragma Elaborate (CC70001_0); +package CC70001_4 is new CC70001_0 (CC70001_3.Points); + +with CC70001_0.CC70001_1; -- Generic extension to list abstraction. +with CC70001_4; +package CC70001_4.CC70001_5 is new CC70001_4.CC70001_1; + + + --==================================================================-- + + +with CC70001_2; -- Generic "zeroing" op for lists of discrete types. +with CC70001_3; -- Types for application. +with CC70001_4.CC70001_5; -- Discrete list abstraction + additional ops. + +with Report; +procedure CC70001 is + + package Lists_Of_Scores renames CC70001_4; + package Score_Ops renames CC70001_4.CC70001_5; + + Scores : Lists_Of_Scores.List_Type; -- List of points. + + procedure Reset_All_Scores is new CC70001_2 -- Operation on lists of + (Elem_Type => CC70001_3.Points, -- points. + List_Mgr => Lists_Of_Scores, + List_Ops => Score_Ops); + + + -- Begin test code declarations: ----------------------- + + type TC_Score_Array is array (1 .. 3) of CC70001_3.Points; + + TC_Initial_Values : constant TC_Score_Array := (2, 4, 6); + TC_Final_Values : constant TC_Score_Array := (0, 0, 0); + + TC_Correct_Initial_Values : Boolean := False; + TC_Correct_Final_Values : Boolean := False; + + + procedure TC_Initialize_List (L : in out Lists_of_Scores.List_Type) is + begin -- Initial list contains 3 scores + for I in TC_Score_Array'Range loop -- with the values 2, 4, and 6. + Score_Ops.Add_Element (L, TC_Initial_Values(I)); + end loop; + end TC_Initialize_List; + + + procedure TC_Verify_List (L : in out Lists_of_Scores.List_Type; + Expected : in TC_Score_Array; + OK : out Boolean) is + Actual : TC_Score_Array; + begin -- Verify that all scores have been + Lists_of_Scores.Reset (L); -- set to zero. + for I in TC_Score_Array'Range loop + Score_Ops.Read_Element (L, Actual(I)); + end loop; + OK := (Actual = Expected); + end TC_Verify_List; + + -- End test code declarations. ------------------------- + + +begin + Report.Test ("CC70001", "Check that the template for a generic formal " & + "package may be a child package, and that a child instance " & + "which is an instance of the template may be passed as an " & + "actual to the formal package. Check that the visible part " & + "of the generic formal package includes the first list of " & + "basic declarative items of the package specification"); + + TC_Initialize_List (Scores); + TC_Verify_List (Scores, TC_Initial_Values, TC_Correct_Initial_Values); + + if not TC_Correct_Initial_Values then + Report.Failed ("List contains incorrect initial values"); + end if; + + Reset_All_Scores (Scores); + TC_Verify_List (Scores, TC_Final_Values, TC_Correct_Final_Values); + + if not TC_Correct_Final_Values then + Report.Failed ("List contains incorrect final values"); + end if; + + Report.Result; +end CC70001; diff --git a/gcc/testsuite/ada/acats/tests/cc/cc70002.a b/gcc/testsuite/ada/acats/tests/cc/cc70002.a new file mode 100644 index 000000000..3e4d9c40b --- /dev/null +++ b/gcc/testsuite/ada/acats/tests/cc/cc70002.a @@ -0,0 +1,241 @@ +-- CC70002.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 formal package actual part may specify actual parameters +-- for a generic formal package. Check that these actual parameters may +-- be formal types, formal objects, and formal subprograms. Check that +-- the visible part of the generic formal package includes the first list +-- of basic declarative items of the package specification, and that if +-- the formal package actual part is (<>), it also includes the generic +-- formal part of the template for the formal package. +-- +-- TEST DESCRIPTION: +-- Declare a generic package which defines a "signature" for mathematical +-- groups. Declare a second generic package which defines a +-- two-dimensional matrix abstraction. Declare a third generic package +-- which provides mathematical group operations for two-dimensional +-- matrices. Provide this third generic with two formal parameters: (1) +-- a generic formal package with the second generic as template and a +-- (<>) actual part, and (2) a generic formal package with the first +-- generic as template and an actual part that takes a formal type, +-- object, and subprogram from the first formal package as actuals. +-- +-- +-- CHANGE HISTORY: +-- 06 Dec 94 SAIC ACVC 2.0 +-- +--! + +generic -- Mathematical group signature. + + type Group_Type is private; + + Identity : in Group_Type; + + with function Operation (Left, Right : Group_Type) return Group_Type; +-- with function Inverse... (omitted for brevity). + +package CC70002_0 is + + function Power (Left : Group_Type; Right : Integer) return Group_Type; + + -- ... Other group operations. + +end CC70002_0; + + + --==================================================================-- + + +package body CC70002_0 is + + -- The implementation of Power is purely artificial; the validity of its + -- implementation in the context of the abstraction is irrelevant to the + -- feature being tested. + + function Power (Left : Group_Type; Right : Integer) return Group_Type is + Result : Group_Type := Identity; + begin + Result := Operation (Result, Left); -- All this really does is add + return Result; -- one to each matrix element. + end Power; + +end CC70002_0; + + + --==================================================================-- + + +generic -- 2D matrix abstraction. + type Element_Type is range <>; + + type Abscissa is range <>; + type Ordinate is range <>; + + type Matrix_2D is array (Abscissa, Ordinate) of Element_Type; +package CC70002_1 is + + Add_Ident : constant Matrix_2D := (Abscissa => (others => 1)); + -- Artificial for + -- testing purposes. + -- ... Other identity matrices. + + + function "+" (A, B : Matrix_2D) return Matrix_2D; + + -- ... Other operations. + +end CC70002_1; + + + --==================================================================-- + + +package body CC70002_1 is + + function "+" (A, B : Matrix_2D) return Matrix_2D is + C : Matrix_2D; + begin + for I in Abscissa loop + for J in Ordinate loop + C(I,J) := A(I,J) + B(I,J); + end loop; + end loop; + return C; + end "+"; + +end CC70002_1; + + + --==================================================================-- + + +with CC70002_0; -- Mathematical group signature. +with CC70002_1; -- 2D matrix abstraction. + +generic -- Mathematical 2D matrix addition group. + + with package Matrix_Ops is new CC70002_1 (<>); + + -- Although the restriction of the formal package below to signatures + -- describing addition groups, and then only for 2D matrices, is rather + -- artificial in the context of this "application," the passing of types, + -- objects, and subprograms as actuals to a formal package is not. + + with package Math_Sig is new CC70002_0 + (Group_Type => Matrix_Ops.Matrix_2D, + Identity => Matrix_Ops.Add_Ident, + Operation => Matrix_Ops."+"); + +package CC70002_2 is + + -- Add two matrices that are to be multiplied by coefficients: + -- [ ] = CA*[ ] + CB*[ ]. + + function Add_Matrices_With_Coefficients (A : Matrix_Ops.Matrix_2D; + CA : Integer; + B : Matrix_Ops.Matrix_2D; + CB : Integer) + return Matrix_Ops.Matrix_2D; + + -- ...Other operations. + +end CC70002_2; + + + --==================================================================-- + + +package body CC70002_2 is + + function Add_Matrices_With_Coefficients (A : Matrix_Ops.Matrix_2D; + CA : Integer; + B : Matrix_Ops.Matrix_2D; + CB : Integer) + return Matrix_Ops.Matrix_2D is + Left, Right : Matrix_Ops.Matrix_2D; + begin + Left := Math_Sig.Power (A, CA); -- Multiply 1st array by its coeff. + Right := Math_Sig.Power (B, CB); -- Multiply 2nd array by its coeff. + return (Matrix_Ops."+" (Left, Right));-- Add these two arrays. + end Add_Matrices_With_Coefficients; + +end CC70002_2; + + + --==================================================================-- + + +with CC70002_0; -- Mathematical group signature. +with CC70002_1; -- 2D matrix abstraction. +with CC70002_2; -- Mathematical 2D matrix addition group. + +with Report; +procedure CC70002 is + + subtype Cell_Type is Positive range 1 .. 3; + subtype Category_Type is Positive range 1 .. 2; + + type Data_Points is new Natural range 0 .. 100; + + type Table_Type is array (Cell_Type, Category_Type) of Data_Points; + + package Data_Table_Support is new CC70002_1 (Data_Points, + Cell_Type, + Category_Type, + Table_Type); + + package Data_Table_Addition_Group is new CC70002_0 + (Group_Type => Table_Type, + Identity => Data_Table_Support.Add_Ident, + Operation => Data_Table_Support."+"); + + package Table_Add_Ops is new CC70002_2 + (Data_Table_Support, Data_Table_Addition_Group); + + + Scores_Table : Table_Type := ( ( 12, 0), + ( 21, 33), + ( 49, 9) ); + Expected : Table_Type := ( ( 26, 2), + ( 44, 68), + ( 100, 20) ); + +begin + Report.Test ("CC70002", "Check that a generic formal package actual " & + "part may specify formal objects, formal subprograms, " & + "and formal types"); + + Scores_Table := Table_Add_Ops.Add_Matrices_With_Coefficients + (Scores_Table, 2, + Scores_Table, 1); + + if (Scores_Table /= Expected) then + Report.Failed ("Incorrect result for multi-dimensional array"); + end if; + + Report.Result; +end CC70002; diff --git a/gcc/testsuite/ada/acats/tests/cc/cc70003.a b/gcc/testsuite/ada/acats/tests/cc/cc70003.a new file mode 100644 index 000000000..d2309fc36 --- /dev/null +++ b/gcc/testsuite/ada/acats/tests/cc/cc70003.a @@ -0,0 +1,212 @@ +-- CC70003.A +-- +-- Grant of Unlimited Rights +-- +-- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687, +-- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained +-- unlimited rights in the software and documentation contained herein. +-- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making +-- this public release, the Government intends to confer upon all +-- recipients unlimited rights equal to those held by the Government. +-- These rights include rights to use, duplicate, release or disclose the +-- released technical data and computer software in whole or in part, in +-- any manner and for any purpose whatsoever, and to have or permit others +-- to do so. +-- +-- DISCLAIMER +-- +-- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR +-- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED +-- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE +-- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE +-- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A +-- PARTICULAR PURPOSE OF SAID MATERIAL. +--* +-- +-- OBJECTIVE: +-- Check that the actual passed to a formal package may be a formal +-- access-to-subprogram type. Check that the visible part of the generic +-- formal package includes the first list of basic declarative items of +-- the package specification. +-- +-- TEST DESCRIPTION: +-- Declare a list abstraction in a generic package which manages lists of +-- elements of any nonlimited type (foundation code). Declare a generic +-- package which supports the execution of lists of operations. Provide +-- the generic package with two formal parameters: (1) a formal access- +-- to-function type, and (2) a generic formal package with the list +-- abstraction package as template. Within a procedure declared in the +-- list-execution package, utilize information about the profile of +-- the functions in the list. Declare a package which declares functions +-- matching the profile of the formal access-to-subprogram type. In the +-- main program, create a list of pointers to the functions declared in +-- the package, instantiate the list abstraction and list-execution +-- packages, and use the list-execution procedure to call each of the +-- functions in the list in sequence. +-- +-- +-- CHANGE HISTORY: +-- 06 Dec 94 SAIC ACVC 2.0 +-- +--! + +generic + type Element_Type is private; +package CC70003_0 is -- This package simulates a generic list abstraction. + + -- The definition of List_Type below is purely artificial; its validity + -- in the context of the abstraction is irrelevant to the feature being + -- tested. + + type Element_Ptr is access Element_Type; + + subtype List_Size is Natural range 1 .. 2; + type List_Type is array (List_Size) of Element_Ptr; + + function View_Element (I : List_Size; L : List_Type) return Element_Type; + + procedure Write_Element (I : in List_Size; + L : in out List_Type; + E : in Element_Type); + + -- ... Other list operations for Element_Type. + +end CC70003_0; + + + --==================================================================-- + + +package body CC70003_0 is + + -- The implementations of the operations below are purely artificial; the + -- validity of their implementations in the context of the abstraction is + -- irrelevant to the feature being tested. + + function View_Element (I : List_Size; L : List_Type) return Element_Type is + begin + return L(I).all; + end View_Element; + + + procedure Write_Element (I : in List_Size; + L : in out List_Type; + E : in Element_Type) is + begin + L(I) := new Element_Type'(E); + end Write_Element; + +end CC70003_0; + + + --==================================================================-- + + +with CC70003_0; -- Generic list abstraction. +generic + type Elem_Type is access function (F : Float) return Float; + with package List_Mgr is new CC70003_0 (Elem_Type); +package CC70003_1 is -- This package simulates support for executing lists + -- of operations. + + procedure Execute_List (L : List_Mgr.List_Type; F : in out Float); + + -- ... Other operations. + +end CC70003_1; + + + --==================================================================-- + + +package body CC70003_1 is + + procedure Execute_List (L : List_Mgr.List_Type; F : in out Float) is + begin + for I in L'Range loop + F := List_Mgr.View_Element(I, L)(F); -- Execute next operation in + end loop; -- list with current value of + end Execute_List; -- F as operand. + + +end CC70003_1; + + + --==================================================================-- + + +package CC70003_2 is + + function Sine (F : Float) return Float; + function Exp (F : Float) return Float; + + -- ... Other math functions. + +end CC70003_2; + + + --==================================================================-- + + +package body CC70003_2 is + + -- The implementations of the functions below are purely artificial; the + -- validity of their implementations in the context of the abstraction is + -- irrelevant to the feature being tested. + + function Sine (F : Float) return Float is + begin + return (-0.15); + end Sine; + + function Exp (F : Float) return Float is + begin + if (F = 0.0) then + return (-0.69); + else + return (2.0); -- This branch should be taken. + end if; + end Exp; + +end CC70003_2; + + + --==================================================================-- + + +with CC70003_0; -- Generic list abstraction. +with CC70003_1; -- Generic operation-list abstraction. +with CC70003_2; -- Math library. + +with Report; +procedure CC70003 is + + type Math_Op is access function (F : Float) return Float; + + package Math_Op_Lists is new CC70003_0 (Math_Op); + package Math_Op_List_Support is new CC70003_1 (Math_Op, Math_Op_Lists); + + Sin_Ptr : Math_Op := CC70003_2.Sine'Access; + Exp_Ptr : Math_Op := CC70003_2.Exp'Access; + + Op_List : Math_Op_Lists.List_Type; + + Operand : Float := 0.0; + Expected : Float := 2.0; + + +begin + Report.Test ("CC70003", "Check that the actual passed to a formal " & + "package may be a formal access-to-subprogram type"); + + Math_Op_Lists.Write_Element (1, Op_List, Sin_Ptr); + Math_Op_Lists.Write_Element (2, Op_List, Exp_Ptr); + + Math_Op_List_Support.Execute_List (Op_List, Operand); + + if (Operand /= Expected) then + Report.Failed ("Incorrect results from indirect function calls"); + end if; + + Report.Result; +end CC70003; diff --git a/gcc/testsuite/ada/acats/tests/cc/cc70a01.a b/gcc/testsuite/ada/acats/tests/cc/cc70a01.a new file mode 100644 index 000000000..ac92f437a --- /dev/null +++ b/gcc/testsuite/ada/acats/tests/cc/cc70a01.a @@ -0,0 +1,208 @@ +-- CC70A01.A +-- +-- Grant of Unlimited Rights +-- +-- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687, +-- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained +-- unlimited rights in the software and documentation contained herein. +-- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making +-- this public release, the Government intends to confer upon all +-- recipients unlimited rights equal to those held by the Government. +-- These rights include rights to use, duplicate, release or disclose the +-- released technical data and computer software in whole or in part, in +-- any manner and for any purpose whatsoever, and to have or permit others +-- to do so. +-- +-- DISCLAIMER +-- +-- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR +-- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED +-- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE +-- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE +-- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A +-- PARTICULAR PURPOSE OF SAID MATERIAL. +--* +-- +-- OBJECTIVE: +-- Check that the visible part of a generic formal package includes the +-- first list of basic declarative items of the package specification. +-- Check for a generic package which declares a formal package with (<>) +-- as its actual part. +-- +-- TEST DESCRIPTION: +-- The "first list of basic declarative items" of a package specification +-- is the visible part of the package. Thus, the declarations in the +-- visible part of the actual instance corresponding to a formal +-- package are available in the generic which declares the formal package. +-- +-- Declare a generic package which simulates a complex integer abstraction +-- (foundation code). +-- +-- Declare a second, library-level generic package which utilizes the +-- first generic package as a generic formal package (with a (<>) +-- actual_part). In the second generic package, declare objects, types, +-- and operations in terms of the objects, types, and operations declared +-- in the first generic package. +-- +-- In the main program, instantiate the first generic package, then +-- instantiate the second generic package and pass the first instance +-- to it as a generic actual parameter. Check that the operations in +-- the second instance perform as expected. +-- +-- +-- CHANGE HISTORY: +-- 06 Dec 94 SAIC ACVC 2.0 +-- +--! + +with FC70A00; -- Generic complex integer operations. + +generic -- Generic complex matrix operations. + with package Complex_Package is new FC70A00 (<>); +package CC70A01_0 is + + type Complex_Matrix_Type is -- 1st index is matrix + array (Positive range <>, Positive range <>) -- row, 2nd is column. + of Complex_Package.Complex_Type; + Dimension_Mismatch : exception; + + + function Identity_Matrix (Size : Positive) -- Create identity matrix + return Complex_Matrix_Type; -- of specified size. + + function "*" (Left : Complex_Matrix_Type; -- Multiply two complex + Right : Complex_Matrix_Type) -- matrices. + return Complex_Matrix_Type; + +end CC70A01_0; + + + --==================================================================-- + + +package body CC70A01_0 is -- Generic complex matrix operations. + + use Complex_Package; + + --==============================================-- + + function Inner_Product (Left, Right : Complex_Matrix_Type; + Row, Column : Positive) -- Compute inner product + return Complex_Package.Complex_Type is -- for matrix-multiply. + + Result : Complex_Type := Zero; + subtype Vector_Size is Positive range Left'Range(2); + + begin -- Inner_Product. + for I in Vector_Size loop + Result := Result + -- Complex_Package."+". + (Left(Row, I) * Right(I, Column)); -- Complex_Package."*". + end loop; + return (Result); + end Inner_Product; + + --==============================================-- + + function Identity_Matrix (Size : Positive) return Complex_Matrix_Type is + Result : Complex_Matrix_Type (1 .. Size, 1 .. Size) := + (others => (others => Zero)); -- Zeroes everywhere... + begin + for I in 1 .. Size loop + Result (I, I) := One; -- Ones on the diagonal. + end loop; + return (Result); + end Identity_Matrix; + + --==============================================-- + + function "*" (Left : Complex_Matrix_Type; Right : Complex_Matrix_Type) + return Complex_Matrix_Type is + + subtype Rows is Positive range Left'Range(1); + subtype Columns is Positive range Right'Range(2); + + Result : Complex_Matrix_Type(Rows, Columns); + begin + if Left'Length(2) /= Right'Length(1) then -- # columns of Left must + -- match # rows of Right. + raise Dimension_Mismatch; + else + for I in Rows loop + for J in Columns loop + Result(I, J) := Inner_Product (Left, Right, I, J); + end loop; + end loop; + return (Result); + end if; + end "*"; + +end CC70A01_0; + + + --==================================================================-- + + +with Report; + +with FC70A00; -- Generic complex integer operations. +with CC70A01_0; -- Generic complex matrix operations. + +procedure CC70A01 is + + type My_Integer is range -100 .. 100; + + package My_Complex_Package is new FC70A00 (My_Integer); + package My_Matrix_Package is new CC70A01_0 (My_Complex_Package); + + use My_Complex_Package, -- All user-defined + My_Matrix_Package; -- operators directly + -- visible. + + subtype Matrix_2x2 is Complex_Matrix_Type (1 .. 2, 1 .. 2); + subtype Matrix_2x3 is Complex_Matrix_Type (1 .. 2, 1 .. 3); + + function C (Real, Imag : My_Integer) return Complex_Type renames Complex; + +begin -- Main program. + + Report.Test ("CC70A01", "Check that the visible part of a generic " & + "formal package includes the first list of basic " & + "declarative items of the package specification. Check " & + "for a generic package where formal package has (<>) " & + "actual part"); + + declare + Identity_2x2 : Matrix_2x2 := Identity_Matrix (Size => 2); + Operand_2x3 : Matrix_2x3 := ( ( C(1, 2), C(3, 6), C(5, 1) ), + ( C(0, 3), C(7, 9), C(3, 4) ) ); + Result_2x3 : Matrix_2x3 := ( others => ( others => Zero ) ); + begin + + begin -- Block #1. + Result_2x3 := Identity_2x2 * Operand_2x3; -- Should return + -- Operand_2x3. + if (Result_2x3 /= Operand_2x3) then + Report.Failed ("Incorrect results from matrix multiplication"); + end if; + exception + when others => + Report.Failed ("Unexpected exception raised - Block #1"); + end; -- Block #1. + + + begin -- Block #2. + Result_2x3 := Operand_2x3 * Identity_2x2; -- Can't multiply 2x3 + -- by 2x2. + Report.Failed ("Exception Dimension_Mismatch not raised"); + exception + when Dimension_Mismatch => + null; + when others => + Report.Failed ("Unexpected exception raised - Block #2"); + end; -- Block #2. + + end; + + Report.Result; + +end CC70A01; diff --git a/gcc/testsuite/ada/acats/tests/cc/cc70a02.a b/gcc/testsuite/ada/acats/tests/cc/cc70a02.a new file mode 100644 index 000000000..3601ce443 --- /dev/null +++ b/gcc/testsuite/ada/acats/tests/cc/cc70a02.a @@ -0,0 +1,193 @@ +-- CC70A02.A +-- +-- Grant of Unlimited Rights +-- +-- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687, +-- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained +-- unlimited rights in the software and documentation contained herein. +-- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making +-- this public release, the Government intends to confer upon all +-- recipients unlimited rights equal to those held by the Government. +-- These rights include rights to use, duplicate, release or disclose the +-- released technical data and computer software in whole or in part, in +-- any manner and for any purpose whatsoever, and to have or permit others +-- to do so. +-- +-- DISCLAIMER +-- +-- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR +-- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED +-- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE +-- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE +-- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A +-- PARTICULAR PURPOSE OF SAID MATERIAL. +--* +-- +-- OBJECTIVE: +-- Check that the visible part of a generic formal package includes the +-- first list of basic declarative items of the package specification. +-- Check for a generic subprogram which declares a formal package with +-- (<>) as its actual part. +-- +-- TEST DESCRIPTION: +-- The "first list of basic declarative items" of a package specification +-- is the visible part of the package. Thus, the declarations in the +-- visible part of the actual instance corresponding to a formal +-- package are available in the generic which declares the formal package. +-- +-- Declare a generic package which simulates a complex integer abstraction +-- (foundation code). +-- +-- Declare a second generic package which defines a "signature" for +-- mathematical groups. Declare a generic function within a package +-- which utilizes the second generic package as a generic formal package +-- (with a (<>) actual_part). +-- +-- In the main program, instantiate the first generic package, then +-- instantiate the second generic package with objects, types, and +-- operations declared in the first instance. +-- +-- Instantiate the generic function and pass the second instance +-- to it as a generic actual parameter. Check that the instance of the +-- generic function performs as expected. +-- +-- +-- CHANGE HISTORY: +-- 06 Dec 94 SAIC ACVC 2.0 +-- +--! + +generic -- Mathematical group signature. + + type Group_Type is private; + + Identity : in Group_Type; + + with function Operation (Left, Right : Group_Type) return Group_Type; + with function Inverse (Right : Group_Type) return Group_Type; + +package CC70A02_0 is end; + +-- No body for CC70A02_0. + + + --==================================================================-- + + +with CC70A02_0; -- Mathematical group signature. + +package CC70A02_1 is -- Mathematical group operations. + + -- -- + -- Generic formal package used here -- + -- -- + + generic -- Powers for mathematical groups. + with package Group is new CC70A02_0 (<>); + function Power (Left : Group.Group_Type; Right : Integer) + return Group.Group_Type; + + +end CC70A02_1; + + + --==================================================================-- + + +package body CC70A02_1 is -- Mathematical group operations. + + + + function Power (Left : Group.Group_Type; Right : Integer) + return Group.Group_Type is + Result : Group.Group_Type := Group.Identity; + begin + for I in 1 .. abs(Right) loop -- Repeat group operations + Result := Group.Operation (Result, Left); -- the specified number of + end loop; -- times. + + if Right < 0 then -- If specified power is + return Group.Inverse (Result); -- negative, return the + else -- inverse of the result. + return Result; -- If it is zero, return + end if; -- the identity. + end Power; + + +end CC70A02_1; + + + --==================================================================-- + + +with Report; + +with FC70A00; -- Complex integer abstraction. +with CC70A02_0; -- Mathematical group signature. +with CC70A02_1; -- Mathematical group operations. + +procedure CC70A02 is + + -- Declare an instance of complex integers: + + type My_Integer is range -100 .. 100; + package Complex_Integers is new FC70A00 (My_Integer); + + + -- Define an addition group for complex integers: + + package Complex_Addition_Group is new CC70A02_0 + (Group_Type => Complex_Integers.Complex_Type, -- For complex integers... + Identity => Complex_Integers.Zero, -- Additive identity. + Operation => Complex_Integers."+", -- Additive operation. + Inverse => Complex_Integers."-"); -- Additive inverse. + + function Complex_Multiplication is new -- Multiplication of a + CC70A02_1.Power(Complex_Addition_Group); -- complex integer by a + -- constant. + + + -- Define a multiplication group for complex integers: + + package Complex_Multiplication_Group is new CC70A02_0 + (Group_Type => Complex_Integers.Complex_Type, -- For complex integers... + Identity => Complex_Integers.One, -- Multiplicative identity. + Operation => Complex_Integers."*", -- Multiplicative oper. + Inverse => Complex_Integers.Reciprocal); -- Multiplicative inverse. + + function Complex_Exponentiation is new -- Exponentiation of a + CC70A02_1.Power(Complex_Multiplication_Group); -- complex integer by a + -- constant. + + use Complex_Integers; + + +begin -- Main program. + + Report.Test ("CC70A02", "Check that the visible part of a generic " & + "formal package includes the first list of basic " & + "declarative items of the package specification. Check " & + "for a generic subprogram where formal package has (<>) " & + "actual part"); + + declare + Mult_Operand : constant Complex_Type := Complex ( -4, 9); + Exp_Operand : constant Complex_Type := Complex ( 0, -7); + + Expected_Mult_Result : constant Complex_Type := Complex ( 28, -63); + Expected_Exp_Result : constant Complex_Type := Complex (-49, 0); + begin + + if Complex_Multiplication (Mult_Operand, -7) /= Expected_Mult_Result then + Report.Failed ("Incorrect results from complex multiplication"); + end if; + + if Complex_Exponentiation (Exp_Operand, 2) /= Expected_Exp_Result then + Report.Failed ("Incorrect results from complex exponentiation"); + end if; + + end; + + Report.Result; + +end CC70A02; diff --git a/gcc/testsuite/ada/acats/tests/cc/cc70b01.a b/gcc/testsuite/ada/acats/tests/cc/cc70b01.a new file mode 100644 index 000000000..6c514e17b --- /dev/null +++ b/gcc/testsuite/ada/acats/tests/cc/cc70b01.a @@ -0,0 +1,170 @@ +-- CC70B01.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 formal package actual part may specify actual parameters +-- for a generic formal package. Check that a use clause in the generic +-- formal part provides direct visibility of declarations within the +-- generic formal package. Check that the scope of such a use clause +-- extends to the generic subprogram body. Check that the visible part of +-- the generic formal package includes the first list of basic +-- declarative items of the package specification. +-- +-- Check the case where the formal package is declared in a generic +-- subprogram. +-- +-- TEST DESCRIPTION: +-- Declare a list abstraction in a generic package which manages lists of +-- elements of any nonlimited type (foundation code). Declare a generic +-- subprogram which operates on lists of elements of discrete types. +-- Provide the generic subprogram with two formal parameters: (1) a +-- formal discrete type which represents a list element type, and (2) a +-- generic formal package with the list abstraction package as template. +-- Use the formal discrete type as the generic formal actual part for the +-- formal package. Include a use clause for the formal package in the +-- generic subprogram formal part. +-- +-- TEST FILES: +-- The following files comprise this test: +-- +-- FC70B00.A +-- CC70B01.A +-- +-- +-- CHANGE HISTORY: +-- 06 Dec 94 SAIC ACVC 2.0 +-- +--! + +-- Declare a generic subprogram which performs an operation on lists of +-- discrete objects. + +with FC70B00; -- Generic list abstraction. +generic + + -- Import the list abstraction defined in FC70B00. To ensure that only + -- list abstraction instances defining lists of *discrete* elements will be + -- accepted as actuals to this generic, declare a formal discrete type and + -- pass it as an actual parameter to the formal package. + -- + -- Only instances declared for the same discrete type as that used to + -- instantiate this generic subprogram will be accepted. + + type Elem_Type is (<>); -- Discrete types only. + with package List_Mgr is new FC70B00 (Elem_Type); + + use List_Mgr; -- Use clause for formal package. + +procedure CC70B01_0 (L : in out List_Type); -- List_Mgr.List_Type directly + -- visible. + + + --==================================================================-- + + +procedure CC70B01_0 (L : in out List_Type) is -- Declarations in List_Mgr +begin -- still directly visible. + Reset (L); + while not End_Of_List (L) loop + Write_Element (L, Elem_Type'First); -- This statement assumes + end loop; -- Elem_Type is discrete. +end CC70B01_0; + + + --==================================================================-- + + +with FC70B00; -- Generic list abstraction. +with CC70B01_0; -- Generic "zeroing" operation for lists of discrete types. + +with Report; +procedure CC70B01 is + + type Points is range 0 .. 10; -- Discrete type. + package Lists_of_Scores is new FC70B00 (Points); -- List-of-points + -- abstraction. + Scores : Lists_of_Scores.List_Type; -- List of points. + + procedure Reset_All_Scores is new -- Operation on lists of + CC70B01_0 (Points, Lists_of_Scores); -- points. + + + -- Begin test code declarations: ----------------------- + + type TC_Score_Array is array (1 .. 3) of Points; + + TC_Initial_Values : constant TC_Score_Array := (2, 4, 6); + TC_Final_Values : constant TC_Score_Array := (0, 0, 0); + + TC_Correct_Initial_Values : Boolean := False; + TC_Correct_Final_Values : Boolean := False; + + + procedure TC_Initialize_List (L : in out Lists_of_Scores.List_Type) is + begin -- Initial list contains 3 scores + for I in TC_Score_Array'Range loop -- with the values 2, 4, and 6. + Lists_of_Scores.Add_Element (L, TC_Initial_Values(I)); + end loop; + end TC_Initialize_List; + + + procedure TC_Verify_List (L : in out Lists_of_Scores.List_Type; + Expected : in TC_Score_Array; + OK : out Boolean) is + Actual : TC_Score_Array; + begin -- Verify that all scores have been + Lists_of_Scores.Reset (L); -- set to zero. + for I in TC_Score_Array'Range loop + Lists_of_Scores.Read_Element (L, Actual(I)); + end loop; + OK := (Actual = Expected); + end TC_Verify_List; + + -- End test code declarations. ------------------------- + + +begin + Report.Test ("CC70B01", "Check that a library-level generic subprogram " & + "may have a formal package as a formal parameter, and that " & + "the generic formal actual part may specify explicit actual " & + "parameters. Check that a use clause is legal in the " & + "generic formal part"); + + TC_Initialize_List (Scores); + TC_Verify_List (Scores, TC_Initial_Values, TC_Correct_Initial_Values); + + if not TC_Correct_Initial_Values then + Report.Failed ("List contains incorrect initial values"); + end if; + + Reset_All_Scores (Scores); + TC_Verify_List (Scores, TC_Final_Values, TC_Correct_Final_Values); + + if not TC_Correct_Final_Values then + Report.Failed ("List contains incorrect final values"); + end if; + + Report.Result; +end CC70B01; diff --git a/gcc/testsuite/ada/acats/tests/cc/cc70b02.a b/gcc/testsuite/ada/acats/tests/cc/cc70b02.a new file mode 100644 index 000000000..d27eea843 --- /dev/null +++ b/gcc/testsuite/ada/acats/tests/cc/cc70b02.a @@ -0,0 +1,222 @@ +-- CC70B02.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 formal package actual part may specify actual parameters +-- for a generic formal package. Check that such an actual parameter may +-- be a formal parameter of a previously declared formal package +-- (with a (<>) actual part). Check that a use clause in the generic +-- formal part provides direct visibility of declarations within the +-- generic formal package, including formal parameters (if the formal +-- package has a (<>) actual part). Check that the scope of such a use +-- clause extends to the generic subprogram body. Check that the visible +-- part of the generic formal package includes the first list of basic +-- declarative items of the package specification. +-- +-- Check the case where the formal package is declared in a generic +-- package. +-- +-- TEST DESCRIPTION: +-- Declare a list abstraction in a generic package which manages lists of +-- elements of any nonlimited type (foundation code). Declare a second +-- generic package which declares operations on discrete types. Declare +-- a third generic package which combines the abstractions of the first +-- two generics and declares operations on lists of elements of discrete +-- types. Provide the third generic package with two formal parameters: +-- (1) a generic formal package with the discrete operation package as +-- template, and (2) a generic formal package with the list abstraction +-- package as template. Use the formal discrete type of the discrete +-- operations generic as the generic formal actual part for the second +-- formal package. Include a use clause for the first formal package in +-- the third generic package formal part. +-- +-- TEST FILES: +-- The following files comprise this test: +-- +-- FC70B00.A +-- CC70B02.A +-- +-- +-- CHANGE HISTORY: +-- 06 Dec 94 SAIC ACVC 2.0 +-- +--! + +generic + type Discrete_Type is (<>); -- Discrete types only. +package CC70B02_0 is -- Discrete type operations. + + procedure Double (Object : in out Discrete_Type); + + -- ... Other operations on discrete objects. + +end CC70B02_0; + + + --==================================================================-- + + +package body CC70B02_0 is + + procedure Double (Object : in out Discrete_Type) is + Doubled_Position : Integer := Discrete_Type'Pos (Object) * 2; + begin + -- ... Error-checking code omitted for brevity. + Object := Discrete_Type'Val (Doubled_Position); + end Double; + +end CC70B02_0; + + + --==================================================================-- + + +with CC70B02_0; -- Discrete type operations. +with FC70B00; -- List abstraction. +generic + + -- Import both the discrete-operation and list abstractions. To ensure that + -- only list abstraction instances defining lists of *discrete* elements + -- will be accepted as actuals to this generic, pass the formal discrete + -- type from the discrete-operation abstraction as an actual parameter to + -- the list-abstraction formal package. + -- + -- Only list instances declared for the same discrete type as that used + -- to instantiate the discrete-operation package will be accepted. + + with package Discrete_Ops is new CC70B02_0 (<>); + + use Discrete_Ops; -- Discrete_Ops directly visible. + + with package List_Mgr is new FC70B00 (Discrete_Type); -- Discrete_Type is + -- formal parameter + -- of template for + -- Discrete_Ops. +package CC70B02_1 is -- Discrete list operations. + + procedure Double_List (L : in out List_Mgr.List_Type); + + -- ... Other operations on lists of discrete objects. + +end CC70B02_1; + + + --==================================================================-- + + +package body CC70B02_1 is + + procedure Double_List (L : in out List_Mgr.List_Type) is + Element : Discrete_Type; -- Formal part of Discrete_Ops template + begin -- is directly visible here. + List_Mgr.Reset (L); + while not List_Mgr.End_Of_List (L) loop + List_Mgr.View_Element (L, Element); + Double (Element); + List_Mgr.Write_Element (L, Element); + end loop; + end Double_List; + +end CC70B02_1; + + + --==================================================================-- + + +with FC70B00; -- Generic list abstraction. +with CC70B02_0; -- Generic discrete type operations. +with CC70B02_1; -- Generic discrete list operations. + +with Report; +procedure CC70B02 is + + type Points is range 0 .. 100; -- Discrete type. + + package Points_Ops is new CC70B02_0 (Points); -- Points-type operations. + package Lists_of_Points is new FC70B00 (Points); -- Points lists. + package Points_List_Ops is new -- Points-list operations. + CC70B02_1 (Points_Ops, Lists_Of_Points); + + Scores : Lists_of_Points.List_Type; -- List of points. + + + -- Begin test code declarations: ----------------------- + + type TC_Score_Array is array (1 .. 3) of Points; + + TC_Initial_Values : constant TC_Score_Array := (23, 15, 0); + TC_Final_Values : constant TC_Score_Array := (46, 30, 0); + + TC_Correct_Initial_Values : Boolean := False; + TC_Correct_Final_Values : Boolean := False; + + + procedure TC_Initialize_List (L : in out Lists_Of_Points.List_Type) is + begin -- Initial list contains 3 scores + for I in TC_Score_Array'Range loop -- with the values 23, 15, and 0. + Lists_Of_Points.Add_Element (L, TC_Initial_Values(I)); + end loop; + end TC_Initialize_List; + + + procedure TC_Verify_List (L : in out Lists_Of_Points.List_Type; + Expected : in TC_Score_Array; + OK : out Boolean) is + Actual : TC_Score_Array; + begin -- Verify that all scores have been + Lists_Of_Points.Reset (L); -- set to zero. + for I in TC_Score_Array'Range loop + Lists_Of_Points.Read_Element (L, Actual(I)); + end loop; + OK := (Actual = Expected); + end TC_Verify_List; + + -- End test code declarations. ------------------------- + + +begin + Report.Test ("CC70B02", "Check that a library-level generic package " & + "may have a formal package as a formal parameter, and that " & + "the generic formal actual part may specify explicit actual " & + "parameters (including a formal parameter of a previously " & + "declared formal package). Check that a use clause is legal " & + "in the generic formal part"); + + TC_Initialize_List (Scores); + TC_Verify_List (Scores, TC_Initial_Values, TC_Correct_Initial_Values); + + if not TC_Correct_Initial_Values then + Report.Failed ("List contains incorrect initial values"); + end if; + + Points_List_Ops.Double_List (Scores); + TC_Verify_List (Scores, TC_Final_Values, TC_Correct_Final_Values); + + if not TC_Correct_Final_Values then + Report.Failed ("List contains incorrect final values"); + end if; + + Report.Result; +end CC70B02; diff --git a/gcc/testsuite/ada/acats/tests/cc/cc70c01.a b/gcc/testsuite/ada/acats/tests/cc/cc70c01.a new file mode 100644 index 000000000..f22ad01e7 --- /dev/null +++ b/gcc/testsuite/ada/acats/tests/cc/cc70c01.a @@ -0,0 +1,187 @@ +-- CC70C01.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 generic formal package is an instance. Specifically, +-- check that a generic formal package may be passed as an actual +-- parameter in an instantiation of a generic package. Check that the +-- visible part of the generic formal package includes the first list of +-- basic declarative items of the package specification. +-- +-- TEST DESCRIPTION: +-- A generic formal package is a package, and is an instance. +-- +-- Declare a list type in a generic package for lists of elements of any +-- nonlimited type (foundation code). Declare a second generic package +-- which declares operations for the list type, and parameterize it with +-- a generic formal package with the list-type package as template +-- (foundation code). Declare a third generic package which declares +-- additional operations for the list type, and parameterize it just like +-- the second generic package. Declare an instance of the second generic +-- in the spec of the third generic, passing the formal package as the +-- actual. +-- +-- TEST FILES: +-- The following files comprise this test: +-- +-- FC70C00.A +-- CC70C01.A +-- +-- +-- CHANGE HISTORY: +-- 06 Dec 94 SAIC ACVC 2.0 +-- +--! + +with FC70C00_0; -- List abstraction. +with FC70C00_1; -- Basic list operations. +generic + with package Lists is new FC70C00_0 (<>); +package CC70C01_0 is -- Additional list operations. + + -- Instantiate a generic package (FC70C00_1) with a generic formal package + -- (Lists). This ensures that the package passed as an actual corresponding + -- to Lists is the same one passed as an actual to FC70C00_1. Thus, all list + -- operations from both FC70C00_1 and this package operate on lists of the + -- same element type. + + package Basic_List_Ops is new FC70C00_1 (Lists); + + + End_of_List_Reached : exception; + + + -- Read from current element and advance "current" pointer. + procedure Read_Element (L : in out Lists.List_Type; + E : out Lists.Element_Type); + + -- Add element to end of list. + procedure Add_Element (L : in out Lists.List_Type; + E : in Lists.Element_Type); + +end CC70C01_0; + + + --==================================================================-- + + +package body CC70C01_0 is + + procedure Read_Element (L : in out Lists.List_Type; + E : out Lists.Element_Type) is + begin + if Basic_List_Ops.End_Of_List (L) then -- Use of op from the previous + raise End_Of_List_Reached; -- generic package. + else + E := L.Current.Item; -- Retrieve current element. + L.Current := L.Current.Next; -- Advance "current" pointer. + end if; + end Read_Element; + + + procedure Add_Element (L : in out Lists.List_Type; + E : in Lists.Element_Type) is + New_Node : Lists.Node_Pointer := new Lists.Node_Type'(E, null); + use type Lists.Node_Pointer; + begin + if L.First = null then -- No elements in list, so add new + L.First := New_Node; -- element at beginning of list. + else + L.Last.Next := New_Node; -- Add new element at end of list. + end if; + L.Last := New_Node; -- Set last-in-list pointer. + end Add_Element; + + +end CC70C01_0; + + + --==================================================================-- + + +with FC70C00_0; -- Generic list abstraction. +with CC70C01_0; -- Additional generic list operations. + +with Report; +procedure CC70C01 is + + type Points is range 0 .. 100; -- Discrete type. + + package Lists_of_Points is new FC70C00_0 (Points); -- Points lists. + + package Points_List_Ops is new -- Points-list ops. + CC70C01_0 (Lists_Of_Points); + + Scores : Lists_of_Points.List_Type; -- List of points. + + + -- Begin test code declarations: ----------------------- + + type TC_Score_Array is array (1 .. 3) of Points; + + TC_List_Values : constant TC_Score_Array := (23, 15, 0); + + TC_Correct_List_Values : Boolean := False; + + + procedure TC_Initialize_List (L : in out Lists_Of_Points.List_Type) is + begin -- Initial list contains 3 scores + for I in TC_Score_Array'Range loop -- with the values 23, 15, and 0. + Points_List_Ops.Add_Element (L, TC_List_Values(I)); + end loop; + end TC_Initialize_List; + + + procedure TC_Verify_List (L : in out Lists_Of_Points.List_Type; + Expected : in TC_Score_Array; + OK : out Boolean) is + Actual : TC_Score_Array; + begin + Points_List_Ops.Basic_List_Ops.Reset (L); + for I in TC_Score_Array'Range loop + Points_List_Ops.Read_Element (L, Actual(I)); + end loop; + OK := (Actual = Expected); + end TC_Verify_List; + + -- End test code declarations. ------------------------- + + +begin + + Report.Test ("CC70C01", "Check that a generic formal package may be " & + "passed as an actual in an instantiation of a generic " & + "package"); + + TC_Initialize_List (Scores); + TC_Verify_List (Scores, TC_List_Values, TC_Correct_List_Values); + + if not TC_Correct_List_Values then + Report.Failed ("List contains incorrect values"); + end if; + + Report.Result; + +end CC70C01; diff --git a/gcc/testsuite/ada/acats/tests/cc/cc70c02.a b/gcc/testsuite/ada/acats/tests/cc/cc70c02.a new file mode 100644 index 000000000..f479193b5 --- /dev/null +++ b/gcc/testsuite/ada/acats/tests/cc/cc70c02.a @@ -0,0 +1,192 @@ +-- CC70C02.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 generic formal package is an instance. Specifically, +-- check that a generic formal package may be passed as an actual +-- parameter to another generic formal package. Check that the +-- visible part of the generic formal package includes the first list of +-- basic declarative items of the package specification. +-- +-- TEST DESCRIPTION: +-- A generic formal package is a package, and is an instance. +-- +-- Declare a list type in a generic package for lists of elements of any +-- nonlimited type (foundation code). Declare a second generic package +-- which declares operations for the list type, and parameterize it with +-- a generic formal package with the list-type package as template +-- (foundation code). Declare a third generic package which declares +-- additional operations for the list type, and parameterize it with two +-- generic formal packages, one with the list-type package as template, +-- the other with the second generic package as template. Use the first +-- formal package as the generic formal actual part for the second formal +-- package. +-- +-- TEST FILES: +-- The following files comprise this test: +-- +-- FC70C00.A +-- CC70C02.A +-- +-- +-- CHANGE HISTORY: +-- 06 Dec 94 SAIC ACVC 2.0 +-- +--! + +with FC70C00_0; -- List abstraction. +with FC70C00_1; -- Basic list operations. +generic + + -- Import both the list-type abstraction defined in FC70C00_0 and the basic + -- list operations defined in FC70C00_1. To ensure that only basic operation + -- instances for lists of the same element type as that used to instantiate + -- the list type are accepted as actuals to this generic, pass the list-type + -- formal package as an actual parameter to the list-operation formal + -- package. + + with package Lists is new FC70C00_0 (<>); + with package Basic_List_Ops is new FC70C00_1 (Lists); +package CC70C02_0 is -- Additional list operations. + + End_of_List_Reached : exception; + + + -- Read from current element and advance "current" pointer. + procedure Read_Element (L : in out Lists.List_Type; + E : out Lists.Element_Type); + + -- Add element to end of list. + procedure Add_Element (L : in out Lists.List_Type; + E : in Lists.Element_Type); + +end CC70C02_0; + + + --==================================================================-- + + +package body CC70C02_0 is + + procedure Read_Element (L : in out Lists.List_Type; + E : out Lists.Element_Type) is + begin + if Basic_List_Ops.End_Of_List (L) then -- Use of op from the previous + raise End_Of_List_Reached; -- generic package. + else + E := L.Current.Item; -- Retrieve current element. + L.Current := L.Current.Next; -- Advance "current" pointer. + end if; + end Read_Element; + + + procedure Add_Element (L : in out Lists.List_Type; + E : in Lists.Element_Type) is + New_Node : Lists.Node_Pointer := new Lists.Node_Type'(E, null); + use type Lists.Node_Pointer; + begin + if L.First = null then -- No elements in list, so add new + L.First := New_Node; -- element at beginning of list. + else + L.Last.Next := New_Node; -- Add new element at end of list. + end if; + L.Last := New_Node; -- Set last-in-list pointer. + end Add_Element; + + +end CC70C02_0; + + + --==================================================================-- + + +with FC70C00_0; -- Generic list type abstraction. +with FC70C00_1; -- Generic list operations. +with CC70C02_0; -- Additional generic list operations. + +with Report; +procedure CC70C02 is + + type Points is range 0 .. 100; -- Discrete type. + + package Lists_of_Points is new FC70C00_0 (Points); -- Points lists. + + package Basic_Point_Ops is new -- Basic points-list ops. + FC70C00_1 (Lists_Of_Points); + + package Points_List_Ops is new -- More points-list ops. + CC70C02_0 (Lists => Lists_Of_Points, + Basic_List_Ops => Basic_Point_Ops); + + Scores : Lists_of_Points.List_Type; -- List of points. + + + -- Begin test code declarations: ----------------------- + + type TC_Score_Array is array (1 .. 3) of Points; + + TC_List_Values : constant TC_Score_Array := (23, 15, 0); + + TC_Correct_List_Values : Boolean := False; + + + procedure TC_Initialize_List (L : in out Lists_Of_Points.List_Type) is + begin -- Initial list contains 3 scores + for I in TC_Score_Array'Range loop -- with the values 23, 15, and 0. + Points_List_Ops.Add_Element (L, TC_List_Values(I)); + end loop; + end TC_Initialize_List; + + + procedure TC_Verify_List (L : in out Lists_Of_Points.List_Type; + Expected : in TC_Score_Array; + OK : out Boolean) is + Actual : TC_Score_Array; + begin + Basic_Point_Ops.Reset (L); + for I in TC_Score_Array'Range loop + Points_List_Ops.Read_Element (L, Actual(I)); + end loop; + OK := (Actual = Expected); + end TC_Verify_List; + + -- End test code declarations. ------------------------- + + +begin + + Report.Test ("CC70C02", "Check that a generic formal package may be " & + "passed as an actual to another formal package"); + + TC_Initialize_List (Scores); + TC_Verify_List (Scores, TC_List_Values, TC_Correct_List_Values); + + if not TC_Correct_List_Values then + Report.Failed ("List contains incorrect values"); + end if; + + Report.Result; + +end CC70C02; |