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/ca | |
| 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/ca')
155 files changed, 16550 insertions, 0 deletions
diff --git a/gcc/testsuite/ada/acats/tests/ca/ca1003a.ada b/gcc/testsuite/ada/acats/tests/ca/ca1003a.ada new file mode 100644 index 000000000..b3476b42f --- /dev/null +++ b/gcc/testsuite/ada/acats/tests/ca/ca1003a.ada @@ -0,0 +1,73 @@ +-- CA1003A.ADA + +-- Grant of Unlimited Rights +-- +-- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687, +-- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained +-- unlimited rights in the software and documentation contained herein. +-- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making +-- this public release, the Government intends to confer upon all +-- recipients unlimited rights equal to those held by the Government. +-- These rights include rights to use, duplicate, release or disclose the +-- released technical data and computer software in whole or in part, in +-- any manner and for any purpose whatsoever, and to have or permit others +-- to do so. +-- +-- DISCLAIMER +-- +-- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR +-- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED +-- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF 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 MORE THAN ONE COMPLETELY INDEPENDENT COMPILATION +-- UNIT CAN BE SUBMITTED IN A SINGLE FILE. + +-- JRK 5/13/81 +-- JBG 8/25/83 + +PROCEDURE CA1003A_P (I : IN OUT INTEGER) IS +BEGIN + I := I + 1; +END CA1003A_P; + + +PACKAGE CA1003A_PKG IS + I : INTEGER := 0; +END CA1003A_PKG; + + +FUNCTION CA1003A_F (I : INTEGER) RETURN INTEGER IS +BEGIN + RETURN -I; +END CA1003A_F; + + +WITH REPORT, CA1003A_P, CA1003A_PKG, CA1003A_F; +USE REPORT; + +PROCEDURE CA1003A IS + + I : INTEGER := IDENT_INT (0); + +BEGIN + TEST ("CA1003A", "INDEPENDENT UNITS IN A SINGLE FILE"); + + CA1003A_P (I); + IF I /= 1 THEN + FAILED ("INDEPENDENT PROCEDURE NOT INVOKED"); + END IF; + + CA1003A_PKG.I := CA1003A_PKG.I + IDENT_INT(10); + IF CA1003A_PKG.I /= 10 THEN + FAILED ("INDEPENDENT PACKAGE VARIABLE ACCESSED INCORRECTLY"); + END IF; + + IF CA1003A_F(IDENT_INT(5)) /= -5 THEN + FAILED ("INDEPENDENT FUNCTION NOT INVOKED"); + END IF; + + RESULT; +END CA1003A; diff --git a/gcc/testsuite/ada/acats/tests/ca/ca1004a.ada b/gcc/testsuite/ada/acats/tests/ca/ca1004a.ada new file mode 100644 index 000000000..def868edf --- /dev/null +++ b/gcc/testsuite/ada/acats/tests/ca/ca1004a.ada @@ -0,0 +1,77 @@ +-- CA1004A.ADA + +-- Grant of Unlimited Rights +-- +-- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687, +-- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained +-- unlimited rights in the software and documentation contained herein. +-- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making +-- this public release, the Government intends to confer upon all +-- recipients unlimited rights equal to those held by the Government. +-- These rights include rights to use, duplicate, release or disclose the +-- released technical data and computer software in whole or in part, in +-- any manner and for any purpose whatsoever, and to have or permit others +-- to do so. +-- +-- DISCLAIMER +-- +-- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR +-- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED +-- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF 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 PACKAGE DECLARATION AND BODY CAN BE +-- SUBMITTED TOGETHER FOR COMPILATION. + +-- JRK 5/12/81 + + +PACKAGE CA1004A_PKG IS + + I : INTEGER := 0; + + PROCEDURE P (I : IN OUT INTEGER); + +END CA1004A_PKG; + + +PACKAGE BODY CA1004A_PKG IS + + PROCEDURE P (I : IN OUT INTEGER) IS + BEGIN + I := I + 1; + END P; + +BEGIN + + I := 10; + +END CA1004A_PKG; + + +WITH REPORT, CA1004A_PKG; +USE REPORT; + +PROCEDURE CA1004A IS + + I : INTEGER := IDENT_INT (0); + +BEGIN + TEST ("CA1004A", "A PACKAGE DECLARATION AND BODY SUBMITTED " & + "TOGETHER"); + + CA1004A_PKG.I := CA1004A_PKG.I + IDENT_INT(5); + IF CA1004A_PKG.I /= 15 THEN + FAILED ("PACKAGED VARIABLE NOT ACCESSIBLE OR " & + "PACKAGE BODY NOT EXECUTED"); + END IF; + + CA1004A_PKG.P (I); + IF I /= 1 THEN + FAILED ("PACKAGED PROCEDURE NOT EXECUTED"); + END IF; + + RESULT; +END CA1004A; diff --git a/gcc/testsuite/ada/acats/tests/ca/ca1005a.ada b/gcc/testsuite/ada/acats/tests/ca/ca1005a.ada new file mode 100644 index 000000000..9f9e2a283 --- /dev/null +++ b/gcc/testsuite/ada/acats/tests/ca/ca1005a.ada @@ -0,0 +1,70 @@ +-- CA1005A.ADA + +-- Grant of Unlimited Rights +-- +-- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687, +-- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained +-- unlimited rights in the software and documentation contained herein. +-- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making +-- this public release, the Government intends to confer upon all +-- recipients unlimited rights equal to those held by the Government. +-- These rights include rights to use, duplicate, release or disclose the +-- released technical data and computer software in whole or in part, in +-- any manner and for any purpose whatsoever, and to have or permit others +-- to do so. +-- +-- DISCLAIMER +-- +-- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR +-- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED +-- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE +-- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE +-- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A +-- PARTICULAR PURPOSE OF SAID MATERIAL. +--* +-- CHECK THAT A SUBPROGRAM DECLARATION AND BODY CAN BE +-- SUBMITTED TOGETHER FOR COMPILATION. + +-- JRK 5/14/81 + + +FUNCTION CA1005A_F (I : INTEGER) RETURN INTEGER; + + +FUNCTION CA1005A_F (I : INTEGER) RETURN INTEGER IS +BEGIN + RETURN I + 1; +END CA1005A_F; + + +PROCEDURE CA1005A_P (I : IN OUT INTEGER); + + +PROCEDURE CA1005A_P (I : IN OUT INTEGER) IS +BEGIN + I := -I; +END CA1005A_P; + + +WITH REPORT, CA1005A_F, CA1005A_P; +USE REPORT; + +PROCEDURE CA1005A IS + + I : INTEGER := IDENT_INT (7); + +BEGIN + TEST ("CA1005A", "SUBPROGRAM DECLARATIONS AND BODIES " & + "SUBMITTED TOGETHER"); + + IF CA1005A_F (IDENT_INT(2)) /= 3 THEN + FAILED ("FUNCTION NOT EXECUTED"); + END IF; + + CA1005A_P (I); + IF I /= -7 THEN + FAILED ("PROCEDURE NOT EXECUTED"); + END IF; + + RESULT; +END CA1005A; diff --git a/gcc/testsuite/ada/acats/tests/ca/ca1006a.ada b/gcc/testsuite/ada/acats/tests/ca/ca1006a.ada new file mode 100644 index 000000000..7b3527f58 --- /dev/null +++ b/gcc/testsuite/ada/acats/tests/ca/ca1006a.ada @@ -0,0 +1,106 @@ +-- CA1006A.ADA + +-- Grant of Unlimited Rights +-- +-- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687, +-- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained +-- unlimited rights in the software and documentation contained herein. +-- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making +-- this public release, the Government intends to confer upon all +-- recipients unlimited rights equal to those held by the Government. +-- These rights include rights to use, duplicate, release or disclose the +-- released technical data and computer software in whole or in part, in +-- any manner and for any purpose whatsoever, and to have or permit others +-- to do so. +-- +-- DISCLAIMER +-- +-- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR +-- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED +-- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF 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 LIBRARY UNIT AND ITS SUBUNITS CAN BE +-- SUBMITTED TOGETHER FOR COMPILATION. + +-- JRK 5/14/81 + +WITH REPORT; +USE REPORT; + +PROCEDURE CA1006A IS + + I : INTEGER := IDENT_INT (0); + + PACKAGE CALL_TEST IS + END CALL_TEST; + + PACKAGE BODY CALL_TEST IS + BEGIN + TEST ("CA1006A", "A LIBRARY UNIT AND ITS SUBUNITS " & + "SUBMITTED TOGETHER"); + END CALL_TEST; + + FUNCTION F (I : INTEGER) RETURN INTEGER IS SEPARATE; + + PACKAGE PKG IS + I : INTEGER := IDENT_INT (0); + PROCEDURE P (I : IN OUT INTEGER); + END PKG; + + PACKAGE BODY PKG IS SEPARATE; + + PROCEDURE P (I : IN OUT INTEGER) IS SEPARATE; + +BEGIN + + IF PKG.I /= 10 THEN + FAILED ("PACKAGE BODY STATEMENTS NOT EXECUTED"); + END IF; + + IF F(IDENT_INT(5)) /= -5 THEN + FAILED ("FUNCTION NOT ELABORATED/EXECUTED"); + END IF; + + PKG.P (I); + IF I /= 3 THEN + FAILED ("PACKAGED PROCEDURE NOT ELABORATED/EXECUTED"); + END IF; + + I := IDENT_INT (-20); + P (I); + IF I /= -24 THEN + FAILED ("PROCEDURE NOT ELABORATED/EXECUTED"); + END IF; + + RESULT; +END CA1006A; + + +SEPARATE (CA1006A) +FUNCTION F (I : INTEGER) RETURN INTEGER IS +BEGIN + RETURN -I; +END F; + + +SEPARATE (CA1006A) +PACKAGE BODY PKG IS + + PROCEDURE P (I : IN OUT INTEGER) IS + BEGIN + I := I + 3; + END P; + +BEGIN + I := I + 10; +END PKG; + + +SEPARATE (CA1006A) +PROCEDURE P (I : IN OUT INTEGER) IS +BEGIN + I := I - 4; +END P; diff --git a/gcc/testsuite/ada/acats/tests/ca/ca1011a0.ada b/gcc/testsuite/ada/acats/tests/ca/ca1011a0.ada new file mode 100644 index 000000000..a1c164642 --- /dev/null +++ b/gcc/testsuite/ada/acats/tests/ca/ca1011a0.ada @@ -0,0 +1,35 @@ +-- CA1011A0.ADA + +-- Grant of Unlimited Rights +-- +-- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687, +-- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained +-- unlimited rights in the software and documentation contained herein. +-- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making +-- this public release, the Government intends to confer upon all +-- recipients unlimited rights equal to those held by the Government. +-- These rights include rights to use, duplicate, release or disclose the +-- released technical data and computer software in whole or in part, in +-- any manner and for any purpose whatsoever, and to have or permit others +-- to do so. +-- +-- DISCLAIMER +-- +-- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR +-- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED +-- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE +-- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE +-- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A +-- PARTICULAR PURPOSE OF SAID MATERIAL. +--* +-- BHS 7/20/84 +-- JBG 5/23/85 + +WITH REPORT; USE REPORT; +PROCEDURE CA1011A0 (X : IN OUT INTEGER; Y : IN INTEGER := 2) IS +BEGIN + + X := Y; + FAILED ("DID NOT REPLACE CA1011A0"); + +END CA1011A0; diff --git a/gcc/testsuite/ada/acats/tests/ca/ca1011a1.ada b/gcc/testsuite/ada/acats/tests/ca/ca1011a1.ada new file mode 100644 index 000000000..791d78238 --- /dev/null +++ b/gcc/testsuite/ada/acats/tests/ca/ca1011a1.ada @@ -0,0 +1,36 @@ +-- CA1011A1.ADA + +-- Grant of Unlimited Rights +-- +-- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687, +-- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained +-- unlimited rights in the software and documentation contained herein. +-- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making +-- this public release, the Government intends to confer upon all +-- recipients unlimited rights equal to those held by the Government. +-- These rights include rights to use, duplicate, release or disclose the +-- released technical data and computer software in whole or in part, in +-- any manner and for any purpose whatsoever, and to have or permit others +-- to do so. +-- +-- DISCLAIMER +-- +-- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR +-- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED +-- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE +-- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE +-- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A +-- PARTICULAR PURPOSE OF SAID MATERIAL. +--* +-- BHS 7/20/84 +-- JBG 5/23/85 + +PROCEDURE CA1011A0 (X : IN OUT INTEGER; + Y : IN INTEGER := -1; + Z : IN INTEGER := 2) IS + +BEGIN + + X := 3; + +END CA1011A0; diff --git a/gcc/testsuite/ada/acats/tests/ca/ca1011a2.ada b/gcc/testsuite/ada/acats/tests/ca/ca1011a2.ada new file mode 100644 index 000000000..1125029aa --- /dev/null +++ b/gcc/testsuite/ada/acats/tests/ca/ca1011a2.ada @@ -0,0 +1,35 @@ +-- CA1011A2.ADA + +-- Grant of Unlimited Rights +-- +-- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687, +-- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained +-- unlimited rights in the software and documentation contained herein. +-- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making +-- this public release, the Government intends to confer upon all +-- recipients unlimited rights equal to those held by the Government. +-- These rights include rights to use, duplicate, release or disclose the +-- released technical data and computer software in whole or in part, in +-- any manner and for any purpose whatsoever, and to have or permit others +-- to do so. +-- +-- DISCLAIMER +-- +-- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR +-- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED +-- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE +-- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE +-- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A +-- PARTICULAR PURPOSE OF SAID MATERIAL. +--* +-- BHS 7/20/84 +-- JBG 5/23/85 + +WITH REPORT; USE REPORT; +PROCEDURE CA1011A2 (X : INTEGER := 1; Y : IN OUT FLOAT) IS +BEGIN + + Y := 2.0; + FAILED ("DID NOT REPLACE CA1011A2"); + +END CA1011A2; diff --git a/gcc/testsuite/ada/acats/tests/ca/ca1011a3.ada b/gcc/testsuite/ada/acats/tests/ca/ca1011a3.ada new file mode 100644 index 000000000..a37d04c3e --- /dev/null +++ b/gcc/testsuite/ada/acats/tests/ca/ca1011a3.ada @@ -0,0 +1,34 @@ +-- CA1011A3.ADA + +-- Grant of Unlimited Rights +-- +-- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687, +-- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained +-- unlimited rights in the software and documentation contained herein. +-- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making +-- this public release, the Government intends to confer upon all +-- recipients unlimited rights equal to those held by the Government. +-- These rights include rights to use, duplicate, release or disclose the +-- released technical data and computer software in whole or in part, in +-- any manner and for any purpose whatsoever, and to have or permit others +-- to do so. +-- +-- DISCLAIMER +-- +-- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR +-- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED +-- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE +-- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE +-- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A +-- PARTICULAR PURPOSE OF SAID MATERIAL. +--* +-- BHS 7/20/84 +-- JBG 5/23/85 + +PROCEDURE CA1011A2 (X : BOOLEAN := TRUE; + Y : IN OUT FLOAT) IS +BEGIN + + Y := 3.0; + +END CA1011A2; diff --git a/gcc/testsuite/ada/acats/tests/ca/ca1011a4.ada b/gcc/testsuite/ada/acats/tests/ca/ca1011a4.ada new file mode 100644 index 000000000..68d397240 --- /dev/null +++ b/gcc/testsuite/ada/acats/tests/ca/ca1011a4.ada @@ -0,0 +1,35 @@ +-- CA1011A4.ADA + +-- Grant of Unlimited Rights +-- +-- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687, +-- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained +-- unlimited rights in the software and documentation contained herein. +-- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making +-- this public release, the Government intends to confer upon all +-- recipients unlimited rights equal to those held by the Government. +-- These rights include rights to use, duplicate, release or disclose the +-- released technical data and computer software in whole or in part, in +-- any manner and for any purpose whatsoever, and to have or permit others +-- to do so. +-- +-- DISCLAIMER +-- +-- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR +-- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED +-- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE +-- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE +-- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A +-- PARTICULAR PURPOSE OF SAID MATERIAL. +--* +-- BHS 7/20/84 +-- JBG 5/23/85 + +WITH REPORT; USE REPORT; +FUNCTION CA1011A4 RETURN INTEGER IS +BEGIN + + FAILED ("DID NOT REPLACE CA1011A4"); + RETURN 2; + +END CA1011A4; diff --git a/gcc/testsuite/ada/acats/tests/ca/ca1011a5.ada b/gcc/testsuite/ada/acats/tests/ca/ca1011a5.ada new file mode 100644 index 000000000..2485717e1 --- /dev/null +++ b/gcc/testsuite/ada/acats/tests/ca/ca1011a5.ada @@ -0,0 +1,33 @@ +-- CA1011A5.ADA + +-- Grant of Unlimited Rights +-- +-- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687, +-- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained +-- unlimited rights in the software and documentation contained herein. +-- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making +-- this public release, the Government intends to confer upon all +-- recipients unlimited rights equal to those held by the Government. +-- These rights include rights to use, duplicate, release or disclose the +-- released technical data and computer software in whole or in part, in +-- any manner and for any purpose whatsoever, and to have or permit others +-- to do so. +-- +-- DISCLAIMER +-- +-- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR +-- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED +-- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE +-- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE +-- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A +-- PARTICULAR PURPOSE OF SAID MATERIAL. +--* +-- BHS 7/20/84 +-- JBG 5/23/85 + +FUNCTION CA1011A4 RETURN FLOAT IS +BEGIN + + RETURN 3.0; + +END CA1011A4; diff --git a/gcc/testsuite/ada/acats/tests/ca/ca1011a6.ada b/gcc/testsuite/ada/acats/tests/ca/ca1011a6.ada new file mode 100644 index 000000000..40c562dd5 --- /dev/null +++ b/gcc/testsuite/ada/acats/tests/ca/ca1011a6.ada @@ -0,0 +1,71 @@ +-- CA1011A6M.ADA + +-- Grant of Unlimited Rights +-- +-- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687, +-- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained +-- unlimited rights in the software and documentation contained herein. +-- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making +-- this public release, the Government intends to confer upon all +-- recipients unlimited rights equal to those held by the Government. +-- These rights include rights to use, duplicate, release or disclose the +-- released technical data and computer software in whole or in part, in +-- any manner and for any purpose whatsoever, and to have or permit others +-- to do so. +-- +-- DISCLAIMER +-- +-- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR +-- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED +-- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE +-- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE +-- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A +-- PARTICULAR PURPOSE OF SAID MATERIAL. +--* +-- CHECK THAT IF A SUBPROGRAM BODY IS INITIALLY COMPILED, SUBSEQUENT +-- ATTEMPTS TO COMPILE A SUBPROGRAM BODY WITH A DIFFERENT PARAMETER AND +-- RESULT TYPE PROFILE ARE ACCEPTED (SEE AI-00199). + +-- SEPARATE FILES ARE: +-- CA1011A0 A LIBRARY PROCEDURE (CA1011A0). +-- CA1011A1 A LIBRARY PROCEDURE (CA1011A0). +-- CA1011A2 A LIBRARY PROCEDURE (CA1011A2). +-- CA1011A3 A LIBRARY PROCEDURE (CA1011A2). +-- CA1011A4 A LIBRARY FUNCTION (CA1011A4). +-- CA1011A5 A LIBRARY FUNCTION (CA1011A4). +-- CA1011A6M THE MAIN PROCEDURE. + +-- BHS 7/20/84 +-- JBG 5/23/85 + +WITH CA1011A0, CA1011A2, CA1011A4; +WITH REPORT; USE REPORT; +PROCEDURE CA1011A6M IS + + I : INTEGER := 5; + J : FLOAT := 4.0; + +BEGIN + + TEST("CA1011A", "ATTEMPTS TO RECOMPILE A SUBPROGRAM WITH " & + "NONCONFORMING PARAMETER OR RESULT TYPE " & + "PROFILES ARE ACCEPTED"); + + CA1011A0(X => I); -- EXPECT DEFAULT Y + IF I = 3 THEN + COMMENT ("SECOND DECLARATION OF CA1011A0 INVOKED CORRECTLY"); + END IF; + + CA1011A2(Y => J); -- USE DEFAULT X. + IF J = 3.0 THEN + COMMENT ("SECOND DECLARATION OF CA1011A2 INVOKED CORRECTLY"); + END IF; + + I := INTEGER(CA1011A4); + IF I = 3 THEN + COMMENT ("SECOND DECLARATION OF CA1011A4 INVOKED CORRECTLY"); + END IF; + + RESULT; + +END CA1011A6M; diff --git a/gcc/testsuite/ada/acats/tests/ca/ca1012a0.ada b/gcc/testsuite/ada/acats/tests/ca/ca1012a0.ada new file mode 100644 index 000000000..eec972d73 --- /dev/null +++ b/gcc/testsuite/ada/acats/tests/ca/ca1012a0.ada @@ -0,0 +1,41 @@ +-- CA1012A0.ADA + +-- Grant of Unlimited Rights +-- +-- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687, +-- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained +-- unlimited rights in the software and documentation contained herein. +-- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making +-- this public release, the Government intends to confer upon all +-- recipients unlimited rights equal to those held by the Government. +-- These rights include rights to use, duplicate, release or disclose the +-- released technical data and computer software in whole or in part, in +-- any manner and for any purpose whatsoever, and to have or permit others +-- to do so. +-- +-- DISCLAIMER +-- +-- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR +-- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED +-- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE +-- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE +-- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A +-- PARTICULAR PURPOSE OF SAID MATERIAL. +--* +-- GENERIC PROCEDURE DECLARATION. +-- BODY IS IN CA1012A1.DEP. +-- INSTANTIATION IS IN CA1012A4M.DEP. + +-- APPLICABILITY CRITERIA: +-- THIS UNIT MUST BE ACCEPTED BY ALL ADA 95 IMPLEMENTATIONS. + +-- HISTORY: +-- WKB 07/20/81 CREATED ORIGINAL TEST. +-- PWB 02/19/86 ADDED COMMENTS TO DESCRIBE RELATION TO OTHER FILES +-- AND CLARIFY POSSIBLE NON-APPLICABILITY. +-- BCB 01/05/88 MODIFIED HEADER. +-- RLB 09/13/99 UPDATED APPLICABILITY CRITERIA FOR ADA 95. + +GENERIC + TYPE INDEX IS RANGE <>; +PROCEDURE CA1012A0 (I : IN OUT INDEX); diff --git a/gcc/testsuite/ada/acats/tests/ca/ca1012a1.ada b/gcc/testsuite/ada/acats/tests/ca/ca1012a1.ada new file mode 100644 index 000000000..0e2522f4b --- /dev/null +++ b/gcc/testsuite/ada/acats/tests/ca/ca1012a1.ada @@ -0,0 +1,45 @@ +-- CA1012A1.ADA + +-- Grant of Unlimited Rights +-- +-- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687, +-- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained +-- unlimited rights in the software and documentation contained herein. +-- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making +-- this public release, the Government intends to confer upon all +-- recipients unlimited rights equal to those held by the Government. +-- These rights include rights to use, duplicate, release or disclose the +-- released technical data and computer software in whole or in part, in +-- any manner and for any purpose whatsoever, and to have or permit others +-- to do so. +-- +-- DISCLAIMER +-- +-- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR +-- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED +-- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE +-- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE +-- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A +-- PARTICULAR PURPOSE OF SAID MATERIAL. +--* +-- GENERIC PROCEDURE BODY. +-- DECLARATION IS IN CA1012A0.DEP. +-- INSTANTIATION IN CA1012A4M.DEP. + +-- APPLICABILITY CRITERIA: +-- THIS UNIT MUST BE ACCEPTED BY ALL ADA 95 IMPLEMENTATIONS. + +-- HISTORY: +-- WKB 07/20/81 CREATED ORIGINAL TEST. +-- PWB 02/19/86 ADDED COMMENTS TO DESCRIBE RELATION TO OTHER FILES +-- IN TEST AND POSSIBLE NON-APPLICABILITY. +-- BCB 01/05/88 MODIFIED HEADER. +-- RLB 09/13/99 UPDATED APPLICABILITY CRITERIA FOR ADA 95. + +PROCEDURE CA1012A0 (I : IN OUT INDEX) IS + +BEGIN + + I := I + 1; + +END CA1012A0; diff --git a/gcc/testsuite/ada/acats/tests/ca/ca1012a2.ada b/gcc/testsuite/ada/acats/tests/ca/ca1012a2.ada new file mode 100644 index 000000000..63300b3ad --- /dev/null +++ b/gcc/testsuite/ada/acats/tests/ca/ca1012a2.ada @@ -0,0 +1,41 @@ +-- CA1012A2.ADA + +-- Grant of Unlimited Rights +-- +-- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687, +-- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained +-- unlimited rights in the software and documentation contained herein. +-- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making +-- this public release, the Government intends to confer upon all +-- recipients unlimited rights equal to those held by the Government. +-- These rights include rights to use, duplicate, release or disclose the +-- released technical data and computer software in whole or in part, in +-- any manner and for any purpose whatsoever, and to have or permit others +-- to do so. +-- +-- DISCLAIMER +-- +-- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR +-- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED +-- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE +-- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE +-- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A +-- PARTICULAR PURPOSE OF SAID MATERIAL. +--* +-- GENERIC FUNCTION DECLARATION. +-- BODY IS IN CA1012A3.DEP. +-- INSTANTIATION IS IN CA1012A4M.DEP. + +-- APPLICABILITY CRITERIA: +-- THIS UNIT MUST BE ACCEPTED BY ALL ADA 95 IMPLEMENTATIONS. + +-- HISTORY: +-- WKB 07/20/81 CREATED ORIGINAL TEST. +-- PWB 02/19/86 ADDED COMMENTS TO DESCRIBE RELATION TO OTHER FILES +-- AND POSSIBLE NON-APPLICABILITY. +-- BCB 01/05/88 MODIFIED HEADER. +-- RLB 09/13/99 UPDATED APPLICABILITY CRITERIA FOR ADA 95. + +GENERIC + TYPE ELEMENT IS RANGE <>; +FUNCTION CA1012A2 (J : IN ELEMENT) RETURN ELEMENT; diff --git a/gcc/testsuite/ada/acats/tests/ca/ca1012a3.ada b/gcc/testsuite/ada/acats/tests/ca/ca1012a3.ada new file mode 100644 index 000000000..310777514 --- /dev/null +++ b/gcc/testsuite/ada/acats/tests/ca/ca1012a3.ada @@ -0,0 +1,45 @@ +-- CA1012A3.ADA + +-- Grant of Unlimited Rights +-- +-- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687, +-- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained +-- unlimited rights in the software and documentation contained herein. +-- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making +-- this public release, the Government intends to confer upon all +-- recipients unlimited rights equal to those held by the Government. +-- These rights include rights to use, duplicate, release or disclose the +-- released technical data and computer software in whole or in part, in +-- any manner and for any purpose whatsoever, and to have or permit others +-- to do so. +-- +-- DISCLAIMER +-- +-- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR +-- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED +-- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE +-- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE +-- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A +-- PARTICULAR PURPOSE OF SAID MATERIAL. +--* +-- GENERIC FUNCTION BODY. +-- DECLARATION IS IN CA1012AB.DEP. +-- INSTANTIATION IS IN CA1012A4B.DEP. + +-- APPLICABILITY CRITERIA: +-- THIS UNIT MUST BE ACCEPTED BY ALL ADA 95 IMPLEMENTATIONS. + +-- HISTORY: +-- WKB 07/20/81 CREATED ORIGINAL TEST. +-- PWB 02/19/86 ADDED COMMENTS TO DESCRIBE RELATION TO OTHER FILES +-- AND POSSIBLE NON-APPLICABILITY. +-- BCB 01/05/88 MODIFIED HEADER. +-- RLB 09/13/99 UPDATED APPLICABILITY CRITERIA FOR ADA 95. + +FUNCTION CA1012A2 (J : IN ELEMENT) RETURN ELEMENT IS + +BEGIN + + RETURN J + 1; + +END CA1012A2; diff --git a/gcc/testsuite/ada/acats/tests/ca/ca1012a4.ada b/gcc/testsuite/ada/acats/tests/ca/ca1012a4.ada new file mode 100644 index 000000000..f81b97d4b --- /dev/null +++ b/gcc/testsuite/ada/acats/tests/ca/ca1012a4.ada @@ -0,0 +1,74 @@ +-- CA1012A4M.ADA + +-- Grant of Unlimited Rights +-- +-- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687, +-- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained +-- unlimited rights in the software and documentation contained herein. +-- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making +-- this public release, the Government intends to confer upon all +-- recipients unlimited rights equal to those held by the Government. +-- These rights include rights to use, duplicate, release or disclose the +-- released technical data and computer software in whole or in part, in +-- any manner and for any purpose whatsoever, and to have or permit others +-- to do so. +-- +-- DISCLAIMER +-- +-- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR +-- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED +-- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF 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 SUBPROGRAM DECLARATIONS AND BODIES CAN BE +-- COMPILED SEPARATELY. + +-- SEPARATE FILES ARE: +-- CA1012A0 A LIBRARY GENERIC PROCEDURE DECLARATION. +-- CA1012A1 A LIBRARY GENERIC PROCEDURE BODY (CA1012A0). +-- CA1012A2 A LIBRARY GENERIC FUNCTION DECLARATION. +-- CA1012A3 A LIBRARY GENERIC FUNCTION BODY (CA1012A2). +-- CA1012A4M THE MAIN PROCEDURE. + +-- APPLICABILITY CRITERIA: +-- THIS TEST MUST RUN AND REPORT "PASSED" FOR ALL ADA 95 IMPLEMENTATIONS. +-- THIS WAS NOT REQUIRED FOR ADA 83. + +-- HISTORY: +-- WKB 07/20/81 CREATED ORIGINAL TEST. +-- PWB 02/19/86 ADDED COMMENTS REGARDING NON-APPLICABILITY. +-- BCB 01/05/88 MODIFIED HEADER. +-- RLB 09/13/99 UPDATED APPLICABILITY CRITERIA FOR ADA 95. +-- RLB 09/15/99 REMOVED OBSOLETE COMMENT. + +WITH REPORT, CA1012A0, CA1012A2; +USE REPORT; +PROCEDURE CA1012A4M IS + + N : INTEGER := 1; + + SUBTYPE S50 IS INTEGER RANGE 1..50; + + PROCEDURE P IS NEW CA1012A0 (S50); + + FUNCTION F IS NEW CA1012A2 (INTEGER); + +BEGIN + TEST ("CA1012A", "SEPARATELY COMPILED GENERIC SUBPROGRAM " & + "DECLARATIONS AND BODIES"); + + P(N); + IF N /= 2 THEN + FAILED ("PROCEDURE NOT INVOKED"); + END IF; + + N := 1; + IF F(N) /= 2 THEN + FAILED ("FUNCTION NOT INVOKED"); + END IF; + + RESULT; +END CA1012A4M; diff --git a/gcc/testsuite/ada/acats/tests/ca/ca1012b0.ada b/gcc/testsuite/ada/acats/tests/ca/ca1012b0.ada new file mode 100644 index 000000000..b260ca229 --- /dev/null +++ b/gcc/testsuite/ada/acats/tests/ca/ca1012b0.ada @@ -0,0 +1,37 @@ +-- CA1012B0.ADA + +-- Grant of Unlimited Rights +-- +-- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687, +-- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained +-- unlimited rights in the software and documentation contained herein. +-- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making +-- this public release, the Government intends to confer upon all +-- recipients unlimited rights equal to those held by the Government. +-- These rights include rights to use, duplicate, release or disclose the +-- released technical data and computer software in whole or in part, in +-- any manner and for any purpose whatsoever, and to have or permit others +-- to do so. +-- +-- DISCLAIMER +-- +-- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR +-- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED +-- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE +-- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE +-- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A +-- PARTICULAR PURPOSE OF SAID MATERIAL. +--* +-- WKB 7/20/81 + +GENERIC + TYPE INDEX IS RANGE <>; +PROCEDURE CA1012B0 (I : IN OUT INDEX); + +PROCEDURE CA1012B0 (I : IN OUT INDEX) IS + +BEGIN + + I := I + 1; + +END CA1012B0; diff --git a/gcc/testsuite/ada/acats/tests/ca/ca1012b2.ada b/gcc/testsuite/ada/acats/tests/ca/ca1012b2.ada new file mode 100644 index 000000000..46d2b9301 --- /dev/null +++ b/gcc/testsuite/ada/acats/tests/ca/ca1012b2.ada @@ -0,0 +1,37 @@ +-- CA1012B2.ADA + +-- Grant of Unlimited Rights +-- +-- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687, +-- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained +-- unlimited rights in the software and documentation contained herein. +-- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making +-- this public release, the Government intends to confer upon all +-- recipients unlimited rights equal to those held by the Government. +-- These rights include rights to use, duplicate, release or disclose the +-- released technical data and computer software in whole or in part, in +-- any manner and for any purpose whatsoever, and to have or permit others +-- to do so. +-- +-- DISCLAIMER +-- +-- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR +-- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED +-- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE +-- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE +-- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A +-- PARTICULAR PURPOSE OF SAID MATERIAL. +--* +-- WKB 7/20/81 + +GENERIC + TYPE ELEMENT IS RANGE <>; +FUNCTION CA1012B2 (J : IN ELEMENT) RETURN ELEMENT; + +FUNCTION CA1012B2 (J : IN ELEMENT) RETURN ELEMENT IS + +BEGIN + + RETURN J + 1; + +END CA1012B2; diff --git a/gcc/testsuite/ada/acats/tests/ca/ca1012b4.ada b/gcc/testsuite/ada/acats/tests/ca/ca1012b4.ada new file mode 100644 index 000000000..528ace0d1 --- /dev/null +++ b/gcc/testsuite/ada/acats/tests/ca/ca1012b4.ada @@ -0,0 +1,63 @@ +-- CA1012B4M.ADA + +-- Grant of Unlimited Rights +-- +-- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687, +-- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained +-- unlimited rights in the software and documentation contained herein. +-- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making +-- this public release, the Government intends to confer upon all +-- recipients unlimited rights equal to those held by the Government. +-- These rights include rights to use, duplicate, release or disclose the +-- released technical data and computer software in whole or in part, in +-- any manner and for any purpose whatsoever, and to have or permit others +-- to do so. +-- +-- DISCLAIMER +-- +-- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR +-- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED +-- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF 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 SUBPROGRAM DECLARATIONS AND BODIES CAN BE +-- COMPILED SEPARATELY. + +-- SEPARATE FILES ARE: +-- CA1012B0 A LIBRARY GENERIC PROCEDURE DECLARATION AND BODY. +-- CA1012B2 A LIBRARY GENERIC FUNCTION DECLARATION AND BODY. +-- CA1012B4M THE MAIN PROCEDURE. + +-- WKB 7/20/81 + +WITH REPORT, CA1012B0, CA1012B2; +USE REPORT; +PROCEDURE CA1012B4M IS + + N : INTEGER := 1; + + SUBTYPE S50 IS INTEGER RANGE 1..50; + + PROCEDURE P IS NEW CA1012B0 (S50); + + FUNCTION F IS NEW CA1012B2 (INTEGER); + +BEGIN + TEST ("CA1012B", "SEPARATELY COMPILED GENERIC SUBPROGRAM " & + "DECLARATIONS AND BODIES"); + + P(N); + IF N /= 2 THEN + FAILED ("PROCEDURE NOT INVOKED"); + END IF; + + N := 1; + IF F(N) /= 2 THEN + FAILED ("FUNCTION NOT INVOKED"); + END IF; + + RESULT; + +END CA1012B4M; diff --git a/gcc/testsuite/ada/acats/tests/ca/ca1013a0.ada b/gcc/testsuite/ada/acats/tests/ca/ca1013a0.ada new file mode 100644 index 000000000..937c25f54 --- /dev/null +++ b/gcc/testsuite/ada/acats/tests/ca/ca1013a0.ada @@ -0,0 +1,51 @@ +-- CA1013A0.ADA + +-- Grant of Unlimited Rights +-- +-- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687, +-- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained +-- unlimited rights in the software and documentation contained herein. +-- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making +-- this public release, the Government intends to confer upon all +-- recipients unlimited rights equal to those held by the Government. +-- These rights include rights to use, duplicate, release or disclose the +-- released technical data and computer software in whole or in part, in +-- any manner and for any purpose whatsoever, and to have or permit others +-- to do so. +-- +-- DISCLAIMER +-- +-- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR +-- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED +-- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE +-- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE +-- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A +-- PARTICULAR PURPOSE OF SAID MATERIAL. +--* +-- WKB 7/20/81 +-- PWN 5/25/94 ADDED A PROCEDURE TO KEEP PACKAGE BODIES LEGAL. + + +GENERIC + TYPE ELEM IS RANGE <>; +PACKAGE CA1013A0 IS + + I : ELEM; + + PROCEDURE REQUIRE_BODY; + +END CA1013A0; + + +PACKAGE BODY CA1013A0 IS + + PROCEDURE REQUIRE_BODY IS + BEGIN + NULL; + END; + +BEGIN + + I := 1; + +END CA1013A0; diff --git a/gcc/testsuite/ada/acats/tests/ca/ca1013a1.ada b/gcc/testsuite/ada/acats/tests/ca/ca1013a1.ada new file mode 100644 index 000000000..ddea320bf --- /dev/null +++ b/gcc/testsuite/ada/acats/tests/ca/ca1013a1.ada @@ -0,0 +1,39 @@ +-- CA1013A1.ADA + +-- Grant of Unlimited Rights +-- +-- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687, +-- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained +-- unlimited rights in the software and documentation contained herein. +-- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making +-- this public release, the Government intends to confer upon all +-- recipients unlimited rights equal to those held by the Government. +-- These rights include rights to use, duplicate, release or disclose the +-- released technical data and computer software in whole or in part, in +-- any manner and for any purpose whatsoever, and to have or permit others +-- to do so. +-- +-- DISCLAIMER +-- +-- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR +-- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED +-- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE +-- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE +-- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A +-- PARTICULAR PURPOSE OF SAID MATERIAL. +--* +-- WKB 7/20/81 + + +GENERIC + TYPE INDEX IS RANGE <>; +PROCEDURE CA1013A1 (I : IN OUT INDEX); + + +PROCEDURE CA1013A1 (I : IN OUT INDEX) IS + +BEGIN + + I := I + 1; + +END CA1013A1; diff --git a/gcc/testsuite/ada/acats/tests/ca/ca1013a2.ada b/gcc/testsuite/ada/acats/tests/ca/ca1013a2.ada new file mode 100644 index 000000000..a6843a8e9 --- /dev/null +++ b/gcc/testsuite/ada/acats/tests/ca/ca1013a2.ada @@ -0,0 +1,39 @@ +-- CA1013A2.ADA + +-- Grant of Unlimited Rights +-- +-- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687, +-- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained +-- unlimited rights in the software and documentation contained herein. +-- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making +-- this public release, the Government intends to confer upon all +-- recipients unlimited rights equal to those held by the Government. +-- These rights include rights to use, duplicate, release or disclose the +-- released technical data and computer software in whole or in part, in +-- any manner and for any purpose whatsoever, and to have or permit others +-- to do so. +-- +-- DISCLAIMER +-- +-- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR +-- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED +-- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE +-- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE +-- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A +-- PARTICULAR PURPOSE OF SAID MATERIAL. +--* +-- WKB 7/20/81 + + +GENERIC + TYPE ITEM IS RANGE <>; +FUNCTION CA1013A2 RETURN ITEM; + + +FUNCTION CA1013A2 RETURN ITEM IS + +BEGIN + + RETURN 2; + +END CA1013A2; diff --git a/gcc/testsuite/ada/acats/tests/ca/ca1013a3.ada b/gcc/testsuite/ada/acats/tests/ca/ca1013a3.ada new file mode 100644 index 000000000..a4a805b5d --- /dev/null +++ b/gcc/testsuite/ada/acats/tests/ca/ca1013a3.ada @@ -0,0 +1,31 @@ +-- CA1013A3.ADA + +-- Grant of Unlimited Rights +-- +-- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687, +-- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained +-- unlimited rights in the software and documentation contained herein. +-- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making +-- this public release, the Government intends to confer upon all +-- recipients unlimited rights equal to those held by the Government. +-- These rights include rights to use, duplicate, release or disclose the +-- released technical data and computer software in whole or in part, in +-- any manner and for any purpose whatsoever, and to have or permit others +-- to do so. +-- +-- DISCLAIMER +-- +-- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR +-- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED +-- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE +-- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE +-- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A +-- PARTICULAR PURPOSE OF SAID MATERIAL. +--* +-- WKB 7/20/81 +-- SPS 10/27/82 +-- JBG 9/15/83 + +WITH CA1013A0; +PRAGMA ELABORATE (CA1013A0); +PACKAGE CA1013A3 IS NEW CA1013A0 (INTEGER); diff --git a/gcc/testsuite/ada/acats/tests/ca/ca1013a4.ada b/gcc/testsuite/ada/acats/tests/ca/ca1013a4.ada new file mode 100644 index 000000000..9828c033b --- /dev/null +++ b/gcc/testsuite/ada/acats/tests/ca/ca1013a4.ada @@ -0,0 +1,31 @@ +-- CA1013A4.ADA + +-- Grant of Unlimited Rights +-- +-- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687, +-- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained +-- unlimited rights in the software and documentation contained herein. +-- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making +-- this public release, the Government intends to confer upon all +-- recipients unlimited rights equal to those held by the Government. +-- These rights include rights to use, duplicate, release or disclose the +-- released technical data and computer software in whole or in part, in +-- any manner and for any purpose whatsoever, and to have or permit others +-- to do so. +-- +-- DISCLAIMER +-- +-- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR +-- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED +-- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE +-- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE +-- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A +-- PARTICULAR PURPOSE OF SAID MATERIAL. +--* +-- WKB 7/20/81 +-- SPS 10/27/82 +-- JBG 9/15/83 + +WITH CA1013A1; +PRAGMA ELABORATE (CA1013A1); +PROCEDURE CA1013A4 IS NEW CA1013A1 (INTEGER); diff --git a/gcc/testsuite/ada/acats/tests/ca/ca1013a5.ada b/gcc/testsuite/ada/acats/tests/ca/ca1013a5.ada new file mode 100644 index 000000000..bc858539d --- /dev/null +++ b/gcc/testsuite/ada/acats/tests/ca/ca1013a5.ada @@ -0,0 +1,30 @@ +-- CA1013A5.ADA + +-- Grant of Unlimited Rights +-- +-- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687, +-- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained +-- unlimited rights in the software and documentation contained herein. +-- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making +-- this public release, the Government intends to confer upon all +-- recipients unlimited rights equal to those held by the Government. +-- These rights include rights to use, duplicate, release or disclose the +-- released technical data and computer software in whole or in part, in +-- any manner and for any purpose whatsoever, and to have or permit others +-- to do so. +-- +-- DISCLAIMER +-- +-- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR +-- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED +-- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE +-- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE +-- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A +-- PARTICULAR PURPOSE OF SAID MATERIAL. +--* +-- WKB 7/20/81 +-- JBG 9/15/83 + +WITH CA1013A2; +PRAGMA ELABORATE (CA1013A2); +FUNCTION CA1013A5 IS NEW CA1013A2 (INTEGER); diff --git a/gcc/testsuite/ada/acats/tests/ca/ca1013a6.ada b/gcc/testsuite/ada/acats/tests/ca/ca1013a6.ada new file mode 100644 index 000000000..16c266e45 --- /dev/null +++ b/gcc/testsuite/ada/acats/tests/ca/ca1013a6.ada @@ -0,0 +1,65 @@ +-- CA1013A6M.ADA + +-- Grant of Unlimited Rights +-- +-- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687, +-- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained +-- unlimited rights in the software and documentation contained herein. +-- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making +-- this public release, the Government intends to confer upon all +-- recipients unlimited rights equal to those held by the Government. +-- These rights include rights to use, duplicate, release or disclose the +-- released technical data and computer software in whole or in part, in +-- any manner and for any purpose whatsoever, and to have or permit others +-- to do so. +-- +-- DISCLAIMER +-- +-- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR +-- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED +-- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF 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 GENERIC PACKAGE OR SUBPROGRAM INSTANTIATION +-- CAN BE SUBMITTED FOR SEPARATE COMPILATION. + +-- SEPARATE FILES ARE: +-- CA1013A0 A LIBRARY GENERIC PACKAGE. +-- CA1013A1 A LIBRARY GENERIC PROCEDURE. +-- CA1013A2 A LIBRARY GENERIC FUNCTION. +-- CA1013A3 A LIBRARY GENERIC PACKAGE INSTANTIATION. +-- CA1013A4 A LIBRARY GENERIC PROCEDURE INSTANTIATION. +-- CA1013A5 A LIBRARY GENERIC FUNCTION INSTANTIATION. +-- CA1013A6M THE MAIN PROCEDURE. + +-- WKB 7/20/81 +-- SPS 11/5/82 + +WITH REPORT; +WITH CA1013A3, CA1013A4, CA1013A5; +USE REPORT; +PROCEDURE CA1013A6M IS + + J : INTEGER := 1; + +BEGIN + TEST ("CA1013A", "GENERIC INSTANTIATIONS SUBMITTED " & + "FOR SEPARATE COMPILATION"); + + IF CA1013A3.I /= 1 THEN + FAILED ("PACKAGE NOT ACCESSED"); + END IF; + + CA1013A4 (J); + IF J /= 2 THEN + FAILED ("PROCEDURE NOT INVOKED"); + END IF; + + IF CA1013A5 /= 2 THEN + FAILED ("FUNCTION NOT INVOKED"); + END IF; + + RESULT; +END CA1013A6M; diff --git a/gcc/testsuite/ada/acats/tests/ca/ca1014a0.ada b/gcc/testsuite/ada/acats/tests/ca/ca1014a0.ada new file mode 100644 index 000000000..cf5e93d96 --- /dev/null +++ b/gcc/testsuite/ada/acats/tests/ca/ca1014a0.ada @@ -0,0 +1,85 @@ +-- CA1014A0M.ADA + +-- Grant of Unlimited Rights +-- +-- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687, +-- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained +-- unlimited rights in the software and documentation contained herein. +-- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making +-- this public release, the Government intends to confer upon all +-- recipients unlimited rights equal to those held by the Government. +-- These rights include rights to use, duplicate, release or disclose the +-- released technical data and computer software in whole or in part, in +-- any manner and for any purpose whatsoever, and to have or permit others +-- to do so. +-- +-- DISCLAIMER +-- +-- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR +-- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED +-- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF 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 SUBUNIT CAN BE SUBMITTED FOR COMPILATION +-- SEPARATELY FROM ITS PARENT UNIT. + +-- SEPARATE FILES ARE: +-- CA1014A0M THE MAIN PROCEDURE. +-- CA1014A1 A SUBUNIT PROCEDURE BODY. +-- CA1014A2 A SUBUNIT PACKAGE BODY. +-- CA1014A3 A SUBUNIT FUNCTION BODY. + +-- JRK 5/20/81 + +WITH REPORT; +USE REPORT; + +PROCEDURE CA1014A0M IS + + I : INTEGER := 0; + + PACKAGE CALL_TEST IS + END CALL_TEST; + + PACKAGE BODY CALL_TEST IS + BEGIN + TEST ("CA1014A", "SUBUNITS SUBMITTED FOR COMPILATION " & + "SEPARATELY FROM PARENT UNIT"); + END CALL_TEST; + + PROCEDURE CA1014A1 (I : IN OUT INTEGER) IS SEPARATE; + + PACKAGE CA1014A2 IS + I : INTEGER := 10; + PROCEDURE P (I : IN OUT INTEGER); + END CA1014A2; + + PACKAGE BODY CA1014A2 IS SEPARATE; + + FUNCTION CA1014A3 (I : INTEGER) RETURN INTEGER IS SEPARATE; + +BEGIN + + CA1014A1 (I); + IF I /= 1 THEN + FAILED ("SUBUNIT PROCEDURE NOT ELABORATED/EXECUTED"); + END IF; + + IF CA1014A2.I /= 15 THEN + FAILED ("SUBUNIT PACKAGE BODY NOT ELABORATED/EXECUTED"); + END IF; + + I := 0; + CA1014A2.P (I); + IF I /= -20 THEN + FAILED ("SUBUNIT PACKAGED PROCEDURE NOT ELABORATED/EXECUTED"); + END IF; + + IF CA1014A3(50) /= -50 THEN + FAILED ("SUBUNIT FUNCTION NOT ELABORATED/EXECUTED"); + END IF; + + RESULT; +END CA1014A0M; diff --git a/gcc/testsuite/ada/acats/tests/ca/ca1014a1.ada b/gcc/testsuite/ada/acats/tests/ca/ca1014a1.ada new file mode 100644 index 000000000..d66b677bb --- /dev/null +++ b/gcc/testsuite/ada/acats/tests/ca/ca1014a1.ada @@ -0,0 +1,34 @@ +-- CA1014A1.ADA + +-- Grant of Unlimited Rights +-- +-- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687, +-- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained +-- unlimited rights in the software and documentation contained herein. +-- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making +-- this public release, the Government intends to confer upon all +-- recipients unlimited rights equal to those held by the Government. +-- These rights include rights to use, duplicate, release or disclose the +-- released technical data and computer software in whole or in part, in +-- any manner and for any purpose whatsoever, and to have or permit others +-- to do so. +-- +-- DISCLAIMER +-- +-- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR +-- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED +-- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE +-- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE +-- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A +-- PARTICULAR PURPOSE OF SAID MATERIAL. +--* +-- JRK 5/20/81 + +SEPARATE (CA1014A0M) +PROCEDURE CA1014A1 (I : IN OUT INTEGER) IS + +BEGIN + + I := I + 1; + +END CA1014A1; diff --git a/gcc/testsuite/ada/acats/tests/ca/ca1014a2.ada b/gcc/testsuite/ada/acats/tests/ca/ca1014a2.ada new file mode 100644 index 000000000..9c23ef1f9 --- /dev/null +++ b/gcc/testsuite/ada/acats/tests/ca/ca1014a2.ada @@ -0,0 +1,39 @@ +-- CA1014A2.ADA + +-- Grant of Unlimited Rights +-- +-- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687, +-- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained +-- unlimited rights in the software and documentation contained herein. +-- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making +-- this public release, the Government intends to confer upon all +-- recipients unlimited rights equal to those held by the Government. +-- These rights include rights to use, duplicate, release or disclose the +-- released technical data and computer software in whole or in part, in +-- any manner and for any purpose whatsoever, and to have or permit others +-- to do so. +-- +-- DISCLAIMER +-- +-- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR +-- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED +-- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE +-- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE +-- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A +-- PARTICULAR PURPOSE OF SAID MATERIAL. +--* +-- JRK 5/20/81 + +SEPARATE (CA1014A0M) +PACKAGE BODY CA1014A2 IS + + PROCEDURE P (I : IN OUT INTEGER) IS + BEGIN + I := I - 20; + END P; + +BEGIN + + I := I + 5; + +END CA1014A2; diff --git a/gcc/testsuite/ada/acats/tests/ca/ca1014a3.ada b/gcc/testsuite/ada/acats/tests/ca/ca1014a3.ada new file mode 100644 index 000000000..cd76acc6f --- /dev/null +++ b/gcc/testsuite/ada/acats/tests/ca/ca1014a3.ada @@ -0,0 +1,34 @@ +-- CA1014A3.ADA + +-- Grant of Unlimited Rights +-- +-- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687, +-- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained +-- unlimited rights in the software and documentation contained herein. +-- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making +-- this public release, the Government intends to confer upon all +-- recipients unlimited rights equal to those held by the Government. +-- These rights include rights to use, duplicate, release or disclose the +-- released technical data and computer software in whole or in part, in +-- any manner and for any purpose whatsoever, and to have or permit others +-- to do so. +-- +-- DISCLAIMER +-- +-- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR +-- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED +-- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE +-- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE +-- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A +-- PARTICULAR PURPOSE OF SAID MATERIAL. +--* +-- JRK 5/20/81 + +SEPARATE (CA1014A0M) +FUNCTION CA1014A3 (I : INTEGER) RETURN INTEGER IS + +BEGIN + + RETURN -I; + +END CA1014A3; diff --git a/gcc/testsuite/ada/acats/tests/ca/ca1020e0.ada b/gcc/testsuite/ada/acats/tests/ca/ca1020e0.ada new file mode 100644 index 000000000..93ecc023f --- /dev/null +++ b/gcc/testsuite/ada/acats/tests/ca/ca1020e0.ada @@ -0,0 +1,53 @@ +-- CA1020E0.ADA + +-- Grant of Unlimited Rights +-- +-- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687, +-- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained +-- unlimited rights in the software and documentation contained herein. +-- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making +-- this public release, the Government intends to confer upon all +-- recipients unlimited rights equal to those held by the Government. +-- These rights include rights to use, duplicate, release or disclose the +-- released technical data and computer software in whole or in part, in +-- any manner and for any purpose whatsoever, and to have or permit others +-- to do so. +-- +-- DISCLAIMER +-- +-- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR +-- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED +-- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE +-- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE +-- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A +-- PARTICULAR PURPOSE OF SAID MATERIAL. +--* +-- OBJECTIVE: +-- CHECK THAT A SUBPROGRAM LIBRARY UNIT CAN BE REPLACED BY A GENERIC +-- INSTANTIATION HAVING THE SAME IDENTIFIER. THIS FILE CONTAINS +-- GENERIC UNITS TO BE INSTANTIATED AS LIBRARY UNITS. + +-- HISTORY: +-- JBG 05/28/85 CREATED ORIGINAL TEST. +-- JET 07/29/88 ADDED CASES IN WHICH SUBPROGRAM PROFILES ARE NOT +-- THE SAME AND ALSO WHEN SUBPROGRAM IS FIRST +-- DECLARED WITHOUT A BODY. + +GENERIC + C : INTEGER; +PROCEDURE GENPROC_CA1020E (X : OUT INTEGER); + +WITH REPORT; USE REPORT; +PRAGMA ELABORATE (REPORT); +PROCEDURE GENPROC_CA1020E (X : OUT INTEGER) IS +BEGIN + X := IDENT_INT(C); +END GENPROC_CA1020E; + +GENERIC +FUNCTION GENFUNC_CA1020E RETURN INTEGER; + +FUNCTION GENFUNC_CA1020E RETURN INTEGER IS +BEGIN + RETURN 2; +END GENFUNC_CA1020E; diff --git a/gcc/testsuite/ada/acats/tests/ca/ca1020e1.ada b/gcc/testsuite/ada/acats/tests/ca/ca1020e1.ada new file mode 100644 index 000000000..e5df714ea --- /dev/null +++ b/gcc/testsuite/ada/acats/tests/ca/ca1020e1.ada @@ -0,0 +1,59 @@ +-- CA1020E1.ADA + +-- Grant of Unlimited Rights +-- +-- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687, +-- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained +-- unlimited rights in the software and documentation contained herein. +-- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making +-- this public release, the Government intends to confer upon all +-- recipients unlimited rights equal to those held by the Government. +-- These rights include rights to use, duplicate, release or disclose the +-- released technical data and computer software in whole or in part, in +-- any manner and for any purpose whatsoever, and to have or permit others +-- to do so. +-- +-- DISCLAIMER +-- +-- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR +-- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED +-- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE +-- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE +-- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A +-- PARTICULAR PURPOSE OF SAID MATERIAL. +--* +-- OBJECTIVE: +-- CHECK THAT A SUBPROGRAM LIBRARY UNIT CAN BE REPLACED BY A GENERIC +-- INSTANTIATION HAVING THE SAME IDENTIFIER. THIS FILE CONTAINS +-- SUBPROGRAMS TO BE REPLACED BY LATER GENERIC INSTANTIATIONS. + +-- HISTORY: +-- JBG 05/28/85 CREATED ORIGINAL TEST. +-- JET 07/29/88 ADDED CASES IN WHICH SUBPROGRAM PROFILES ARE NOT +-- THE SAME AND ALSO WHEN SUBPROGRAM IS FIRST +-- DECLARED WITHOUT A BODY. + +PROCEDURE CA1020E_PROC1 (X : OUT INTEGER) IS +BEGIN + X := 3; +END CA1020E_PROC1; + +WITH REPORT; USE REPORT; +PRAGMA ELABORATE (REPORT); +FUNCTION CA1020E_FUNC1 RETURN INTEGER IS +BEGIN + RETURN IDENT_INT(4); +END CA1020E_FUNC1; + +PROCEDURE CA1020E_PROC2 (X : OUT INTEGER); +PROCEDURE CA1020E_PROC2 (X : OUT INTEGER) IS +BEGIN + X := 3; +END CA1020E_PROC2; + +WITH REPORT; USE REPORT; +PRAGMA ELABORATE (REPORT); +FUNCTION CA1020E_FUNC2 RETURN FLOAT IS +BEGIN + RETURN FLOAT(IDENT_INT(4)); +END CA1020E_FUNC2; diff --git a/gcc/testsuite/ada/acats/tests/ca/ca1020e2.ada b/gcc/testsuite/ada/acats/tests/ca/ca1020e2.ada new file mode 100644 index 000000000..7497804fe --- /dev/null +++ b/gcc/testsuite/ada/acats/tests/ca/ca1020e2.ada @@ -0,0 +1,51 @@ +-- CA1020E2.ADA + +-- Grant of Unlimited Rights +-- +-- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687, +-- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained +-- unlimited rights in the software and documentation contained herein. +-- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making +-- this public release, the Government intends to confer upon all +-- recipients unlimited rights equal to those held by the Government. +-- These rights include rights to use, duplicate, release or disclose the +-- released technical data and computer software in whole or in part, in +-- any manner and for any purpose whatsoever, and to have or permit others +-- to do so. +-- +-- DISCLAIMER +-- +-- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR +-- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED +-- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE +-- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE +-- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A +-- PARTICULAR PURPOSE OF SAID MATERIAL. +--* +-- OBJECTIVE: +-- CHECK THAT A SUBPROGRAM LIBRARY UNIT CAN BE REPLACED BY A GENERIC +-- INSTANTIATION HAVING THE SAME IDENTIFIER. THIS FILE CONTAINS +-- GENERIC INSTANTIATIONS REPLACING LIBRARY UNITS CREATED IN +-- CA1020E1. + +-- HISTORY: +-- JBG 05/28/85 CREATED ORIGINAL TEST. +-- JET 07/29/88 ADDED CASES IN WHICH SUBPROGRAM PROFILES ARE NOT +-- THE SAME AND ALSO WHEN SUBPROGRAM IS FIRST +-- DECLARED WITHOUT A BODY. + +WITH GENPROC_CA1020E; +PRAGMA ELABORATE (GENPROC_CA1020E); +PROCEDURE CA1020E_PROC1 IS NEW GENPROC_CA1020E(1); + +WITH GENFUNC_CA1020E; +PRAGMA ELABORATE (GENFUNC_CA1020E); +FUNCTION CA1020E_FUNC1 IS NEW GENFUNC_CA1020E; + +WITH GENPROC_CA1020E; +PRAGMA ELABORATE (GENPROC_CA1020E); +PROCEDURE CA1020E_PROC2 IS NEW GENPROC_CA1020E(5); + +WITH GENFUNC_CA1020E; +PRAGMA ELABORATE (GENFUNC_CA1020E); +FUNCTION CA1020E_FUNC2 IS NEW GENFUNC_CA1020E; diff --git a/gcc/testsuite/ada/acats/tests/ca/ca1020e3.ada b/gcc/testsuite/ada/acats/tests/ca/ca1020e3.ada new file mode 100644 index 000000000..e8ad70f17 --- /dev/null +++ b/gcc/testsuite/ada/acats/tests/ca/ca1020e3.ada @@ -0,0 +1,71 @@ +-- CA1020E3M.ADA + +-- Grant of Unlimited Rights +-- +-- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687, +-- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained +-- unlimited rights in the software and documentation contained herein. +-- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making +-- this public release, the Government intends to confer upon all +-- recipients unlimited rights equal to those held by the Government. +-- These rights include rights to use, duplicate, release or disclose the +-- released technical data and computer software in whole or in part, in +-- any manner and for any purpose whatsoever, and to have or permit others +-- to do so. +-- +-- DISCLAIMER +-- +-- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR +-- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED +-- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE +-- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE +-- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A +-- PARTICULAR PURPOSE OF SAID MATERIAL. +--* +-- OBJECTIVE: +-- CHECK THAT A SUBPROGRAM LIBRARY UNIT CAN BE REPLACED BY A GENERIC +-- INSTANTIATION HAVING THE SAME IDENTIFIER. THIS FILE CONTAINS +-- GENERIC UNITS TO BE INSTANTIATED AS LIBRARY UNITS. + +-- SEPARATE FILES ARE: +-- CA1020E0 -- GENERIC UNITS GENPROC_CA1020E AND GENFUNC_CA1020E. +-- CA1020E1 -- SUBPROGRAM LIBRARY UNIT BODIES (CA1020E_PROC1, +-- CA1020E_FUNC1, CA1020E_PROC2, CA1020E_FUNC2). +-- CA1020E2 -- INSTANTIATIONS REPLACING UNITS COMPILED IN CA1020E1. +-- CA1020E3M -- MAIN PROGRAM. + +-- HISTORY: +-- JBG 05/28/85 CREATED ORIGINAL TEST. +-- JET 07/29/88 ADDED CASES IN WHICH SUBPROGRAM PROFILES ARE NOT +-- THE SAME AND ALSO WHEN SUBPROGRAM IS FIRST +-- DECLARED WITHOUT A BODY. + +WITH REPORT; USE REPORT; +WITH CA1020E_PROC1, CA1020E_FUNC1, CA1020E_PROC2, CA1020E_FUNC2; +PROCEDURE CA1020E3M IS + TEMP : INTEGER := 0; +BEGIN + TEST ("CA1020E", "CHECK THAT A SUBPROGRAM LIBRARY UNIT CAN BE " & + "REPLACED BY A GENERIC INSTANTIATION HAVING " & + "THE SAME IDENTIFIER"); + + CA1020E_PROC1 (TEMP); + IF TEMP /= IDENT_INT(1) THEN + FAILED ("INSTANTIATION DID NOT REPLACE PROCEDURE"); + END IF; + + IF CA1020E_FUNC1 /= IDENT_INT(2) THEN + FAILED ("INSTANTIATION DID NOT REPLACE FUNCTION"); + END IF; + + CA1020E_PROC2 (TEMP); + IF TEMP /= IDENT_INT(5) THEN + FAILED ("INSTANTIATION DID NOT REPLACE PROCEDURE"); + END IF; + + IF CA1020E_FUNC2 /= IDENT_INT(2) THEN + FAILED ("INSTANTIATION DID NOT REPLACE FUNCTION"); + END IF; + + RESULT; +END CA1020E3M; diff --git a/gcc/testsuite/ada/acats/tests/ca/ca1022a0.ada b/gcc/testsuite/ada/acats/tests/ca/ca1022a0.ada new file mode 100644 index 000000000..c3788cc04 --- /dev/null +++ b/gcc/testsuite/ada/acats/tests/ca/ca1022a0.ada @@ -0,0 +1,43 @@ +-- CA1022A0.ADA + +-- Grant of Unlimited Rights +-- +-- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687, +-- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained +-- unlimited rights in the software and documentation contained herein. +-- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making +-- this public release, the Government intends to confer upon all +-- recipients unlimited rights equal to those held by the Government. +-- These rights include rights to use, duplicate, release or disclose the +-- released technical data and computer software in whole or in part, in +-- any manner and for any purpose whatsoever, and to have or permit others +-- to do so. +-- +-- DISCLAIMER +-- +-- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR +-- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED +-- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE +-- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE +-- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A +-- PARTICULAR PURPOSE OF SAID MATERIAL. +--* +-- BHS 7/23/84 + +PACKAGE CA1022A0 IS + + I : INTEGER := 2; + PROCEDURE P0 (X : IN OUT INTEGER ); + +END CA1022A0; + +PACKAGE BODY CA1022A0 IS + + PROCEDURE P0 (X : IN OUT INTEGER) IS + BEGIN + + X := X + 1; + + END P0; + +END CA1022A0; diff --git a/gcc/testsuite/ada/acats/tests/ca/ca1022a1.ada b/gcc/testsuite/ada/acats/tests/ca/ca1022a1.ada new file mode 100644 index 000000000..89ea74851 --- /dev/null +++ b/gcc/testsuite/ada/acats/tests/ca/ca1022a1.ada @@ -0,0 +1,33 @@ +-- CA1022A1.ADA + +-- Grant of Unlimited Rights +-- +-- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687, +-- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained +-- unlimited rights in the software and documentation contained herein. +-- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making +-- this public release, the Government intends to confer upon all +-- recipients unlimited rights equal to those held by the Government. +-- These rights include rights to use, duplicate, release or disclose the +-- released technical data and computer software in whole or in part, in +-- any manner and for any purpose whatsoever, and to have or permit others +-- to do so. +-- +-- DISCLAIMER +-- +-- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR +-- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED +-- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE +-- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE +-- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A +-- PARTICULAR PURPOSE OF SAID MATERIAL. +--* +-- BHS 7/23/84 + +WITH CA1022A0; +PROCEDURE CA1022A1 (Y : IN OUT INTEGER) IS +BEGIN + + CA1022A0.P0 (Y); + +END CA1022A1; diff --git a/gcc/testsuite/ada/acats/tests/ca/ca1022a2.ada b/gcc/testsuite/ada/acats/tests/ca/ca1022a2.ada new file mode 100644 index 000000000..c7e874b29 --- /dev/null +++ b/gcc/testsuite/ada/acats/tests/ca/ca1022a2.ada @@ -0,0 +1,33 @@ +-- CA1022A2.ADA + +-- Grant of Unlimited Rights +-- +-- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687, +-- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained +-- unlimited rights in the software and documentation contained herein. +-- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making +-- this public release, the Government intends to confer upon all +-- recipients unlimited rights equal to those held by the Government. +-- These rights include rights to use, duplicate, release or disclose the +-- released technical data and computer software in whole or in part, in +-- any manner and for any purpose whatsoever, and to have or permit others +-- to do so. +-- +-- DISCLAIMER +-- +-- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR +-- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED +-- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE +-- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE +-- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A +-- PARTICULAR PURPOSE OF SAID MATERIAL. +--* +-- BHS 7/23/84 + +WITH CA1022A0; +FUNCTION CA1022A2 (Z : INTEGER := 1) RETURN BOOLEAN IS +BEGIN + + RETURN TRUE; + +END CA1022A2; diff --git a/gcc/testsuite/ada/acats/tests/ca/ca1022a3.ada b/gcc/testsuite/ada/acats/tests/ca/ca1022a3.ada new file mode 100644 index 000000000..6c5e9deb7 --- /dev/null +++ b/gcc/testsuite/ada/acats/tests/ca/ca1022a3.ada @@ -0,0 +1,53 @@ +-- CA1022A3.ADA + +-- Grant of Unlimited Rights +-- +-- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687, +-- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained +-- unlimited rights in the software and documentation contained herein. +-- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making +-- this public release, the Government intends to confer upon all +-- recipients unlimited rights equal to those held by the Government. +-- These rights include rights to use, duplicate, release or disclose the +-- released technical data and computer software in whole or in part, in +-- any manner and for any purpose whatsoever, and to have or permit others +-- to do so. +-- +-- DISCLAIMER +-- +-- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR +-- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED +-- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE +-- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE +-- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A +-- PARTICULAR PURPOSE OF SAID MATERIAL. +--* +-- RECOMPILATION OF PACKAGE CA1022A0. + +-- BHS 7/23/84 + +PACKAGE CA1022A0 IS + + I, J : INTEGER; + PROCEDURE P0 (X : IN OUT INTEGER); + FUNCTION F RETURN INTEGER; + +END CA1022A0; + +PACKAGE BODY CA1022A0 IS + + PROCEDURE P0 (X : IN OUT INTEGER) IS + BEGIN + + X := X + 2; + + END P0; + + FUNCTION F RETURN INTEGER IS + BEGIN + + RETURN 3; + + END F; + +END CA1022A0; diff --git a/gcc/testsuite/ada/acats/tests/ca/ca1022a4.ada b/gcc/testsuite/ada/acats/tests/ca/ca1022a4.ada new file mode 100644 index 000000000..17837a659 --- /dev/null +++ b/gcc/testsuite/ada/acats/tests/ca/ca1022a4.ada @@ -0,0 +1,36 @@ +-- CA1022A4.ADA + +-- Grant of Unlimited Rights +-- +-- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687, +-- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained +-- unlimited rights in the software and documentation contained herein. +-- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making +-- this public release, the Government intends to confer upon all +-- recipients unlimited rights equal to those held by the Government. +-- These rights include rights to use, duplicate, release or disclose the +-- released technical data and computer software in whole or in part, in +-- any manner and for any purpose whatsoever, and to have or permit others +-- to do so. +-- +-- DISCLAIMER +-- +-- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR +-- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED +-- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE +-- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE +-- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A +-- PARTICULAR PURPOSE OF SAID MATERIAL. +--* +-- RECOMPILATION OF PROCEDURE CA1022A1. + +-- BHS 7/23/84 + +WITH CA1022A0; +PROCEDURE CA1022A1 (Y : IN OUT INTEGER) IS +BEGIN + + Y := 3; + CA1022A0.P0 (Y); + +END CA1022A1; diff --git a/gcc/testsuite/ada/acats/tests/ca/ca1022a5.ada b/gcc/testsuite/ada/acats/tests/ca/ca1022a5.ada new file mode 100644 index 000000000..005748ee3 --- /dev/null +++ b/gcc/testsuite/ada/acats/tests/ca/ca1022a5.ada @@ -0,0 +1,34 @@ +-- CA1022A5.ADA + +-- Grant of Unlimited Rights +-- +-- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687, +-- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained +-- unlimited rights in the software and documentation contained herein. +-- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making +-- this public release, the Government intends to confer upon all +-- recipients unlimited rights equal to those held by the Government. +-- These rights include rights to use, duplicate, release or disclose the +-- released technical data and computer software in whole or in part, in +-- any manner and for any purpose whatsoever, and to have or permit others +-- to do so. +-- +-- DISCLAIMER +-- +-- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR +-- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED +-- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE +-- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE +-- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A +-- PARTICULAR PURPOSE OF SAID MATERIAL. +--* +-- RECOMPILATION OF FUNCTION CA1022A2 (DECL AND BODY). + +-- BHS 7/23/84 + +FUNCTION CA1022A2 (Z : INTEGER := 1) RETURN BOOLEAN IS +BEGIN + + RETURN Z /= 1; + +END CA1022A2; diff --git a/gcc/testsuite/ada/acats/tests/ca/ca1022a6.ada b/gcc/testsuite/ada/acats/tests/ca/ca1022a6.ada new file mode 100644 index 000000000..b011c9bc5 --- /dev/null +++ b/gcc/testsuite/ada/acats/tests/ca/ca1022a6.ada @@ -0,0 +1,66 @@ +-- CA1022A6M.ADA + +-- Grant of Unlimited Rights +-- +-- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687, +-- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained +-- unlimited rights in the software and documentation contained herein. +-- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making +-- this public release, the Government intends to confer upon all +-- recipients unlimited rights equal to those held by the Government. +-- These rights include rights to use, duplicate, release or disclose the +-- released technical data and computer software in whole or in part, in +-- any manner and for any purpose whatsoever, and to have or permit others +-- to do so. +-- +-- DISCLAIMER +-- +-- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR +-- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED +-- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE +-- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE +-- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A +-- PARTICULAR PURPOSE OF SAID MATERIAL. +--* +-- CHECK THAT IF A SUBPROGRAM BODY IS INITIALLY COMPILED WITH A CONTEXT +-- CLAUSE AND A UNIT NAMED IN THE CONTEXT CLAUSE IS RECOMPILED, THEN AN +-- ATTEMPT TO COMPILE THE BODY AGAIN WILL SUCCEED IF THE CONTEXT CLAUSE +-- IS PRESENT. +-- CHECK THAT IF THE RECOMPILED UNIT IS NOT NEEDED IN THE SUBPROGRAM +-- BODY, THE BODY CAN BE SUCCESSFULLY RECOMPILED WITHOUT MENTIONING THE +-- RECOMPILED UNIT. + +-- SEPARATE FILES ARE: +-- CA1022A0 A LIBRARY PACKAGE. +-- CA1022A1 A LIBRARY PROCEDURE. +-- CA1022A2 A LIBRARY FUNCTION. +-- CA1022A3 A LIBRARY PACKAGE (CA1022A0). +-- CA1022A4 A LIBRARY PROCEDURE (CA1022A1). +-- CA1022A5 A LIBRARY FUNCTION (CA1022A2). +-- CA1022A6M THE MAIN PROCEDURE. + +-- BHS 7/23/84 + +WITH CA1022A1, CA1022A2; +WITH REPORT; USE REPORT; +PROCEDURE CA1022A6M IS + + I : INTEGER := 1; + +BEGIN + + TEST ("CA1022A", "USE OF CONTEXT CLAUSES NAMING RECOMPILED " & + "UNITS WITH RECOMPILED SUBPROGRAMS"); + + CA1022A1(I); + IF I /= 5 THEN + FAILED ("PROCEDURE CA1022A1 NOT INVOKED CORRECTLY"); + END IF; + + IF CA1022A2 THEN + FAILED ("FUNCTION CA1022A2 NOT INVOKED CORRECTLY"); + END IF; + + RESULT; + +END CA1022A6M; diff --git a/gcc/testsuite/ada/acats/tests/ca/ca11001.a b/gcc/testsuite/ada/acats/tests/ca/ca11001.a new file mode 100644 index 000000000..c9d1e486c --- /dev/null +++ b/gcc/testsuite/ada/acats/tests/ca/ca11001.a @@ -0,0 +1,276 @@ +-- CA11001.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 child unit can be used to provide an alternate view and +-- operations on a private type in its parent package. Check that a +-- child unit can be a package. Check that a WITH of a child unit +-- includes an implicit WITH of its ancestor unit. +-- +-- TEST DESCRIPTION: +-- Declare a private type in a package specification. Declare +-- subprograms for the type. +-- +-- Add a public child to the above package. Within the body of this +-- package, access the private type. Declare operations to read and +-- write to its parent private type. +-- +-- In the main program, "with" the child. Declare objects of the +-- parent private type. Access the subprograms from both parent and +-- child packages. +-- +-- +-- CHANGE HISTORY: +-- 06 Dec 94 SAIC ACVC 2.0 +-- +--! + +package CA11001_0 is -- Cartesian_Complex +-- This package represents a Cartesian view of a complex number. It contains +-- a private type plus subprograms to construct and decompose a complex +-- number. + + type Complex_Int is range 0 .. 100; + + type Complex_Type is private; + + Constant_Complex : constant Complex_Type; + + Complex_Error : exception; + + procedure Cartesian_Assign (R, I : in Complex_Int; + C : out Complex_Type); + + function Cartesian_Real_Part (C : Complex_Type) + return Complex_Int; + + function Cartesian_Imag_Part (C : Complex_Type) + return Complex_Int; + + function Complex (Real, Imaginary : Complex_Int) + return Complex_Type; + +private + type Complex_Type is -- Parent private type + record + Real, Imaginary : Complex_Int; + end record; + + Constant_Complex : constant Complex_Type := (Real => 0, Imaginary => 0); + +end CA11001_0; -- Cartesian_Complex + +--=======================================================================-- + +package body CA11001_0 is -- Cartesian_Complex + + procedure Cartesian_Assign (R, I : in Complex_Int; + C : out Complex_Type) is + begin + C.Real := R; + C.Imaginary := I; + end Cartesian_Assign; + ------------------------------------------------------------- + function Cartesian_Real_Part (C : Complex_Type) + return Complex_Int is + begin + return C.Real; + end Cartesian_Real_Part; + ------------------------------------------------------------- + function Cartesian_Imag_Part (C : Complex_Type) + return Complex_Int is + begin + return C.Imaginary; + end Cartesian_Imag_Part; + ------------------------------------------------------------- + function Complex (Real, Imaginary : Complex_Int) + return Complex_Type is + begin + return (Real, Imaginary); + end Complex; + +end CA11001_0; -- Cartesian_Complex + +--=======================================================================-- + +package CA11001_0.CA11001_1 is -- Polar_Complex +-- This public child provides a different view of the private type from its +-- parent. It provides a polar view by the provision of subprograms which +-- construct and decompose a complex number. + + procedure Polar_Assign (R, Theta : in Complex_Int; + C : out Complex_Type); + -- Complex_Type is a + -- record of CA11001_0 + + function Polar_Real_Part (C: Complex_Type) return Complex_Int; + + function Polar_Imag_Part (C: Complex_Type) return Complex_Int; + + function Equals_Const (Num : Complex_Type) return Boolean; + +end CA11001_0.CA11001_1; -- Polar_Complex + +--=======================================================================-- + +package body CA11001_0.CA11001_1 is -- Polar_Complex + + function Cos (Angle : Complex_Int) return Complex_Int is + Num : constant Complex_Int := 2; + begin + return (Angle * Num); -- not true Cosine function + end Cos; + ------------------------------------------------------------- + function Sine (Angle : Complex_Int) return Complex_Int is + begin + return 1; -- not true Sine function + end Sine; + ------------------------------------------------------------- + function Sqrt (Num : Complex_Int) + return Complex_Int is + begin + return (Num); -- not true Square root function + end Sqrt; + ------------------------------------------------------------- + function Tan (Angle : Complex_Int) return Complex_Int is + begin + return Angle; -- not true Tangent function + end Tan; + ------------------------------------------------------------- + procedure Polar_Assign (R, Theta : in Complex_Int; + C : out Complex_Type) is + begin + if R = 0 and Theta = 0 then + raise Complex_Error; + end if; + C.Real := R * Cos (Theta); + C.Imaginary := R * Sine (Theta); + end Polar_Assign; + ------------------------------------------------------------- + function Polar_Real_Part (C: Complex_Type) return Complex_Int is + begin + return Sqrt ((Cartesian_Imag_Part (C)) ** 2 + + (Cartesian_Real_Part (C)) ** 2); + end Polar_Real_Part; + ------------------------------------------------------------- + function Polar_Imag_Part (C: Complex_Type) return Complex_Int is + begin + return (Tan (Cartesian_Imag_Part (C) / + Cartesian_Real_Part (C))); + end Polar_Imag_Part; + ------------------------------------------------------------- + function Equals_Const (Num : Complex_Type) return Boolean is + begin + return Num.Real = Constant_Complex.Real and + Num.Imaginary = Constant_Complex.Imaginary; + end Equals_Const; + +end CA11001_0.CA11001_1; -- Polar_Complex + +--=======================================================================-- + +with CA11001_0.CA11001_1; -- Polar_Complex +with Report; + +procedure CA11001 is + + Complex_No : CA11001_0.Complex_Type; -- Complex_Type is a + -- record of CA11001_0 + + Complex_5x2 : CA11001_0.Complex_Type := CA11001_0.Complex (5, 2); + + Int_2 : CA11001_0.Complex_Int + := CA11001_0.Complex_Int (Report.Ident_Int (2)); + +begin + + Report.Test ("CA11001", "Check that a child unit can be used " & + "to provide an alternate view and operations " & + "on a private type in its parent package"); + + Basic_View_Subtest: + + begin + -- Assign using Cartesian coordinates. + CA11001_0.Cartesian_Assign + (CA11001_0.Complex_Int (Report.Ident_Int (1)), Int_2, Complex_No); + + -- Read back in Polar coordinates. + -- Polar values are surrogates used in checking for correct + -- subprogram calls. + if CA11001_0."/=" (CA11001_0.CA11001_1.Polar_Real_Part (Complex_No), + CA11001_0.Cartesian_Real_Part (Complex_5x2)) and CA11001_0."/=" + (CA11001_0.CA11001_1.Polar_Imag_Part (Complex_No), + CA11001_0.Cartesian_Imag_Part (Complex_5x2)) then + Report.Failed ("Incorrect Cartesian result"); + end if; + + end Basic_View_Subtest; + ------------------------------------------------------------- + Alternate_View_Subtest: + begin + -- Assign using Polar coordinates. + CA11001_0.CA11001_1.Polar_Assign + (Int_2, CA11001_0.Complex_Int (Report.Ident_Int (3)), Complex_No); + + -- Read back in Cartesian coordinates. + if CA11001_0."/=" (CA11001_0.Cartesian_Real_Part + (Complex_No), CA11001_0.Complex_Int (Report.Ident_Int (12))) or + CA11001_0."/=" (CA11001_0.Cartesian_Imag_Part (Complex_No), Int_2) + then + Report.Failed ("Incorrect Polar result"); + end if; + end Alternate_View_Subtest; + ------------------------------------------------------------- + Other_Subtest: + begin + -- Assign using Polar coordinates. + CA11001_0.CA11001_1.Polar_Assign + (CA11001_0.Complex_Int (Report.Ident_Int (0)), Int_2, Complex_No); + + -- Compare with Complex_Num in CA11001_0. + if not CA11001_0.CA11001_1.Equals_Const (Complex_No) + then + Report.Failed ("Incorrect result"); + end if; + end Other_Subtest; + ------------------------------------------------------------- + Exception_Subtest: + begin + -- Raised parent's exception. + CA11001_0.CA11001_1.Polar_Assign + (CA11001_0.Complex_Int (Report.Ident_Int (0)), + CA11001_0.Complex_Int (Report.Ident_Int (0)), Complex_No); + Report.Failed ("Exception was not raised"); + exception + when CA11001_0.Complex_Error => + null; + when others => + Report.Failed ("Unexpected exception raised in test"); + end Exception_Subtest; + + Report.Result; + +end CA11001; diff --git a/gcc/testsuite/ada/acats/tests/ca/ca11002.a b/gcc/testsuite/ada/acats/tests/ca/ca11002.a new file mode 100644 index 000000000..189e1944c --- /dev/null +++ b/gcc/testsuite/ada/acats/tests/ca/ca11002.a @@ -0,0 +1,238 @@ +-- CA11002.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 public child can utilize its parent unit's visible +-- definitions. +-- +-- TEST DESCRIPTION: +-- Declare a parent package that contains the following: type, object, +-- constant, exception, and subprograms. Declare a public child unit +-- that utilizes the components found in the visible part of its parent. +-- +-- Demonstrate utilization of the following parent components in the +-- child package: +-- +-- Parent +-- Type X +-- Constant X +-- Object X +-- Subprogram X +-- Exception X +-- +-- This abstraction simulates a portion of a simple operating system. +-- +-- +-- CHANGE HISTORY: +-- 06 Dec 94 SAIC ACVC 2.0 +-- +--! + +package CA11002_0 is -- Package OS. + + type File_Descriptor is new Integer; + type File_Mode is (Read_Only, Write_Only, Read_Write); + + Null_File : constant File_Descriptor := 0; + Default_Mode : constant File_Mode := Read_Only; + Active_Mode : constant File_Mode := Read_Write; + + type File_Type is + record + Descriptor : File_Descriptor := Null_File; + Mode : File_Mode := Default_Mode; + end record; + + System_File : File_Type; + File_Mode_Error : exception; + + function Next_Available_File return File_Descriptor; + + function Mode_Of_File (File : File_Type) return File_Mode; + +end CA11002_0; -- Package OS. + + --=================================================================-- + +package body CA11002_0 is -- Package body OS. + + File_Count : Integer := 0; + + function Next_Available_File return File_Descriptor is + begin + File_Count := File_Count + 1; + return (File_Descriptor(File_Count)); -- Type conversion. + end Next_Available_File; + -------------------------------------------------------------- + function Mode_Of_File (File : File_Type) return File_Mode is + Mode : File_Mode := File.Mode; + begin + return (Mode); + end Mode_Of_File; + +end CA11002_0; -- Package body OS. + + --=================================================================-- + +package CA11002_0.CA11002_1 is -- Child package OS.Operations. + + -- Dot qualification of types, objects, etc. from parent is not required + -- in a child unit. + + procedure Create_File (Mode : in File_Mode:= Active_Mode; + File : out File_Type); + +end CA11002_0.CA11002_1; -- Child package OS.Operations. + + --=================================================================-- + +with Report; +package body CA11002_0.CA11002_1 is -- Child package body OS.Operations. + + function New_File_Validated (File : File_Type) -- Ensure that a newly + return Boolean is -- created file has + Result : Boolean := False; -- appropriate values. + begin + if (File.Descriptor > System_File.Descriptor) and -- Parent object. + (File.Mode in File_Mode ) -- Parent type. + then + Result := True; + end if; + + return (Result); + + end New_File_Validated; + -------------------------------------------------------------- + procedure Create_File + (Mode : in File_Mode := Active_Mode; -- Parent constant. + File : out File_Type) is -- Parent type. + + New_File : File_Type; + + begin + New_File.Descriptor := Next_Available_File; -- Parent subprogram. + New_File.Mode := Mode; + + if New_File_Validated (File => New_File) then + File := New_File; + end if; + + end Create_File; + +end CA11002_0.CA11002_1; -- Child Package body OS.Operations. + + --=================================================================-- + +-- Child library subprogram Convert_File_Mode specification. +procedure CA11002_0.CA11002_2 (File : in out File_Type; -- Parent type. + New_Mode : in File_Mode); -- Parent type. + + + --=================================================================-- +with Report; + +-- Child library subprogram Convert_File_Mode body. +procedure CA11002_0.CA11002_2 (File : in out File_Type; + New_Mode : in File_Mode) is +begin + if File.Mode = New_Mode then + raise File_Mode_Error; -- Parent exception. + Report.Failed ("Exception not raised in child unit"); + else + File.Mode := New_Mode; + end if; +end CA11002_0.CA11002_2; + + --=================================================================-- + +with Report; +with CA11002_0.CA11002_1; -- Child package OS.Operations. +with CA11002_0.CA11002_2; -- Child subprogram OS.Convert_File_Mode, + -- Implicitly with parent, OS. +use CA11002_0; -- All user-defined operators directly + -- visible. +procedure CA11002 is +begin + + Report.Test ("CA11002", "Check that a public child can utilize its " & + "parent unit's visible definitions"); + + File_Creation: -- This processing block will demonstrate + -- use of child package subroutine that + -- takes advantage of components declared + -- in the parent package. + declare + User_File : File_Type; + begin + CA11002_0.CA11002_1.Create_File (File => User_File); -- Default mode + -- parameter used in + -- this call. + if (User_File.Descriptor = System_File.Descriptor) or + (User_File.Mode = Default_Mode) + then + Report.Failed ("Incorrect file creation"); + end if; + + end File_Creation; + + -------------------------------------------------------------- + File_Mode_Conversion: -- This processing block will demonstrate + -- the occurrence of a (forced) exception + -- being raised in a child subprogram, and + -- propagated to the caller. The exception + -- is handled, and the child subprogram + -- is called again, this time to perform + -- without error. + declare + procedure Convert_File_Mode (File : in out File_Type; + New_Mode : in File_Mode) renames CA11002_0.CA11002_2; + New_File : File_Type; + begin -- Raise an exception with this + -- illegal conversion operation + -- (attempt to change to current mode). + + Convert_File_Mode (File => New_File, + New_Mode => Default_Mode); + Report.Failed ("Exception should have been raised in child unit"); + + exception + when File_Mode_Error => -- Perform the conversion again, this + -- time with a different file mode. + + Convert_File_Mode (File => New_File, + New_Mode => CA11002_0.Active_Mode); + + if New_File.Mode /= Read_Write then + Report.Failed ("Incorrect result from mode conversion operation"); + end if; + + when others => + Report.Failed ("Unexpected exception raised in File_Mode_Conversion"); + + end File_Mode_Conversion; + + Report.Result; + +end CA11002; diff --git a/gcc/testsuite/ada/acats/tests/ca/ca11003.a b/gcc/testsuite/ada/acats/tests/ca/ca11003.a new file mode 100644 index 000000000..ff894250e --- /dev/null +++ b/gcc/testsuite/ada/acats/tests/ca/ca11003.a @@ -0,0 +1,290 @@ +-- CA11003.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 public grandchild can utilize its ancestor unit's visible +-- definitions. +-- +-- TEST DESCRIPTION: +-- Declare a public package, public child package, and public +-- grandchild package and library unit function. Within the +-- grandchild package and function, make use of components that are +-- declared in the ancestor packages, both parent and grandparent. +-- +-- Use the following ancestral components in the grandchildren library +-- units: +-- Grandparent Parent +-- Type X X +-- Constant X X +-- Object X X +-- Subprogram X X +-- Exception X X +-- +-- +-- CHANGE HISTORY: +-- 06 Dec 94 SAIC ACVC 2.0 +-- 21 Dec 94 SAIC Modified procedure Create_File +-- 15 Nov 95 SAIC Update and repair for ACVC 2.0.1 +-- +--! + +package CA11003_0 is -- Package OS + + type File_Descriptor is new Integer; + type File_Mode is (Read_Only, Write_Only, Read_Write); + + Null_File : constant File_Descriptor := 0; + Default_Mode : constant File_Mode := Read_Only; + File_Data_Error : exception; + + type File_Type is tagged + record + Descriptor : File_Descriptor := Null_File; + Mode : File_Mode := Read_Write; + end record; + + System_File : File_Type; + + function Next_Available_File return File_Descriptor; + + procedure Reclaim_File_Descriptor; + +end CA11003_0; -- Package OS + + --=================================================================-- + +package body CA11003_0 is -- Package body OS + + File_Count : Integer := 0; + + function Next_Available_File return File_Descriptor is + begin + File_Count := File_Count + 1; + return (File_Descriptor(File_Count)); + end Next_Available_File; + -------------------------------------------------- + procedure Reclaim_File_Descriptor is + begin + null; -- Dummy processing unit. + end Reclaim_File_Descriptor; + +end CA11003_0; -- Package body OS + + --=================================================================-- + +package CA11003_0.CA11003_1 is -- Child package OS.Operations + + subtype File_Length_Type is Integer range 0 .. 1000; + Min_File_Size : File_Length_Type := File_Length_Type'First; + Max_File_Size : File_Length_Type := File_Length_Type'Last; + + File_Duplication_Error : exception; + + type Extended_File_Type is new File_Type with private; + + procedure Create_File (Mode : in File_Mode; + File : out Extended_File_Type); + + procedure Duplicate_File (Original : in Extended_File_Type; + Duplicate : out Extended_File_Type); + +private + type Extended_File_Type is new File_Type with + record + Blocks : File_Length_Type := Min_File_Size; + end record; + + System_Extended_File : Extended_File_Type; + +end CA11003_0.CA11003_1; -- Child Package OS.Operations + + --=================================================================-- + +package body CA11003_0.CA11003_1 is -- Child package body OS.Operations + + procedure Create_File + (Mode : in File_Mode; + File : out Extended_File_Type) is + begin + File.Descriptor := Next_Available_File; -- Parent subprogram. + File.Mode := Default_Mode; -- Parent constant. + File.Blocks := Min_File_Size; + end Create_File; + -------------------------------------------------- + procedure Duplicate_File (Original : in Extended_File_Type; + Duplicate : out Extended_File_Type) is + begin + Duplicate.Descriptor := Next_Available_File; -- Parent subprogram. + Duplicate.Mode := Original.Mode; + Duplicate.Blocks := Original.Blocks; + end Duplicate_File; + +end CA11003_0.CA11003_1; -- Child package body OS.Operations + + --=================================================================-- + +-- This package contains menu selectable operations for manipulating files. +-- This abstraction builds on the capabilities available from ancestor +-- packages. + +package CA11003_0.CA11003_1.CA11003_2 is + + procedure News (Mode : in File_Mode; + File : out Extended_File_Type); + + procedure Copy (Original : in Extended_File_Type; + Duplicate : out Extended_File_Type); + + procedure Delete (File : in Extended_File_Type); + +end CA11003_0.CA11003_1.CA11003_2; -- Grandchild package OS.Operations.Menu + + --=================================================================-- + +-- Grandchild subprogram Validate +function CA11003_0.CA11003_1.CA11003_3 (File : in Extended_File_Type) + return Boolean; + + --=================================================================-- + +-- Grandchild subprogram Validate +function CA11003_0.CA11003_1.CA11003_3 + (File : in Extended_File_Type) -- Parent type. + return Boolean is + + function New_File_Validated (File : Extended_File_Type) + return Boolean is + begin + if (File.Descriptor > System_File.Descriptor) and -- Grandparent + (File.Mode in File_Mode ) and -- object and type + not ((File.Blocks < System_Extended_File.Blocks) or + (File.Blocks > Max_File_Size)) -- Parent object + then -- and constant. + return True; + else + return False; + end if; + end New_File_Validated; + +begin + return (New_File_Validated (File)) and + (File.Descriptor /= Null_File); -- Grandparent constant. + +end CA11003_0.CA11003_1.CA11003_3; -- Grandchild subprogram Validate + + --=================================================================-- + +with CA11003_0.CA11003_1.CA11003_3; + -- Grandchild package body OS.Operations.Menu +package body CA11003_0.CA11003_1.CA11003_2 is + + procedure News (Mode : in File_Mode; + File : out Extended_File_Type) is -- Parent type. + begin + Create_File (Mode, File); -- Parent subprogram. + if not CA11003_0.CA11003_1.CA11003_3 (File) then + raise File_Data_Error; -- Grandparent exception. + end if; + end News; + -------------------------------------------------- + procedure Copy (Original : in Extended_File_Type; + Duplicate : out Extended_File_Type) is + begin + Duplicate_File (Original, Duplicate); -- Parent subprogram. + + if Original.Descriptor = Duplicate.Descriptor then + raise File_Duplication_Error; -- Parent exception. + end if; + + end Copy; + -------------------------------------------------- + procedure Delete (File : in Extended_File_Type) is + begin + Reclaim_File_Descriptor; -- Grandparent + end Delete; -- subprogram. + +end CA11003_0.CA11003_1.CA11003_2; + + --=================================================================-- + +with CA11003_0.CA11003_1.CA11003_2; -- Grandchild Pkg OS.Operations.Menu +with CA11003_0.CA11003_1.CA11003_3; -- Grandchild Ftn OS.Operations.Validate +with Report; + +procedure CA11003 is + + package Menu renames CA11003_0.CA11003_1.CA11003_2; + +begin + + Report.Test ("CA11003", "Check that a public grandchild can utilize " & + "its ancestor unit's visible definitions"); + + File_Processing: -- Validate all of the capabilities contained in + -- the Menu package by exercising them on specific + -- files. This will demonstrate the use of child + -- and grandchild functionality based on components + -- that have been declared in the + -- parent/grandparent package. + declare + + function Validate (File : CA11003_0.CA11003_1.Extended_File_Type) + return Boolean renames CA11003_0.CA11003_1.CA11003_3; + + MacWrite_File, + Backup_Copy : CA11003_0.CA11003_1.Extended_File_Type; + MacWrite_File_Mode : CA11003_0.File_Mode := CA11003_0.Read_Write; + + begin + + Menu.News (MacWrite_File_Mode, MacWrite_File); + + if not Validate (MacWrite_File) then + Report.Failed ("Incorrect initialization of files"); + end if; + + Menu.Copy (MacWrite_File, Backup_Copy); + + if not (Validate (MacWrite_File) and + Validate (Backup_Copy)) + then + Report.Failed ("Incorrect duplication of files"); + end if; + + Menu.Delete (Backup_Copy); + + exception + when CA11003_0.File_Data_Error => + Report.Failed ("Exception raised during file validation"); + when CA11003_0.CA11003_1.File_Duplication_Error => + Report.Failed ("Exception raised during file duplication"); + when others => + Report.Failed ("Unexpected exception in test procedure"); + + end File_Processing; + + Report.Result; + +end CA11003; diff --git a/gcc/testsuite/ada/acats/tests/ca/ca110040.a b/gcc/testsuite/ada/acats/tests/ca/ca110040.a new file mode 100644 index 000000000..72cc6682e --- /dev/null +++ b/gcc/testsuite/ada/acats/tests/ca/ca110040.a @@ -0,0 +1,90 @@ +-- CA110040.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: +-- See CA110042.AM +-- +-- TEST DESCRIPTION: +-- See CA110042.AM +-- +-- TEST FILES: +-- The following files comprise this test: +-- +-- => CA110040.A +-- CA110041.A +-- CA110042.AM +-- +-- CHANGE HISTORY: +-- 06 Dec 94 SAIC ACVC 2.0 +-- 26 Apr 96 SAIC ACVC 2.1: Modified prologue; Added pragma +-- Elaborate_Body. +-- +--! + +package CA110040 is -- Package Computer_System. + pragma Elaborate_Body (CA110040); + + -- Types. + type ID_Type is range 1 .. 4; + type System_Account_Capacity is new ID_Type; + + type Account is tagged + record + User_ID : ID_Type; + end record; + + -- Constants. + Maximum_System_Accounts : constant System_Account_Capacity := + System_Account_Capacity'Last; + + System_Administrator : constant ID_Type := + ID_Type (System_Account_Capacity'First); + + Administrator_Account : constant Account := + (User_ID => System_Administrator); + + -- Objects. + Total_Accounts : System_Account_Capacity := 1; + + -- Exceptions. + Illegal_Account : exception; + Account_Limit_Exceeded : exception; + + -- Subprograms. + function Next_Available_ID return ID_Type; + +end CA110040; -- Package Computer_System. + + --=================================================================-- + +package body CA110040 is -- Package body Computer_System. + + function Next_Available_ID return ID_Type is + begin + Total_Accounts := Total_Accounts + 1; + return (ID_Type(Total_Accounts)); + end Next_Available_ID; + +end CA110040; -- Package body Computer_System. diff --git a/gcc/testsuite/ada/acats/tests/ca/ca110041.a b/gcc/testsuite/ada/acats/tests/ca/ca110041.a new file mode 100644 index 000000000..954df7f4d --- /dev/null +++ b/gcc/testsuite/ada/acats/tests/ca/ca110041.a @@ -0,0 +1,118 @@ +-- CA110041.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: +-- See CA110042.AM +-- +-- TEST DESCRIPTION: +-- See CA110042.AM +-- +-- TEST FILES: +-- The following files comprise this test: +-- +-- CA110040.A +-- => CA110041.A +-- CA110042.AM +-- +-- CHANGE HISTORY: +-- 06 Dec 94 SAIC ACVC 2.0 +-- 26 Apr 96 SAIC ACVC 2.1: Modified prologue. +-- +--! + +package CA110040.CA110041 is -- Child Package Computer_System.Manager + + type User_Account is new Account with private; + + procedure Initialize_User_Account (Acct : out User_Account); + +private + +-- The private portion of this spec demonstrates that components contained +-- in the visible part of the parent are directly visible in the private +-- part of a public child. + + type Account_Access_Type is (None, Guest, User, System); + + type User_Account is new Account with -- Parent type. + record + Privilege : Account_Access_Type := None; + end record; + + System_Account : User_Account := + (User_ID => Administrator_Account.User_ID, -- Parent constant. + Privilege => System); -- User_ID has been + -- set to 1. + Auditor_Account : User_Account := + (User_ID => Next_Available_ID, -- Parent function. + Privilege => System); -- User_ID has been + -- set to 2. + Total_Authorized_Accounts : System_Account_Capacity + renames Total_Accounts; -- Parent object. + + Unauthorized_Account : exception + renames Illegal_Account; -- Parent exception + +end CA110040.CA110041; -- Child Package Computer_System.Manager + + --=================================================================-- + + -- Child Package body Computer_System.Manager +package body CA110040.CA110041 is + + function Account_Limit_Reached return Boolean is + begin + if Total_Authorized_Accounts = Maximum_System_Accounts then + return (True); + else + return (False); + end if; + end Account_Limit_Reached; + --------------------------------------------------------------- + function Valid_Account (Acct : User_Account) return Boolean is + Result : Boolean := False; + begin + if (Acct.User_ID /= System_Account.User_ID) and + (Acct.User_ID /= Auditor_Account.User_ID) + then + Result := True; + end if; + return (Result); + end Valid_Account; + --------------------------------------------------------------- + procedure Initialize_User_Account (Acct : out User_Account) is + begin + if Account_Limit_Reached then + raise Account_Limit_Exceeded; + else + Acct.User_ID := Next_Available_ID; + Acct.Privilege := User; + end if; + if not Valid_Account (Acct) then + raise Unauthorized_Account; + end if; + end Initialize_User_Account; + +end CA110040.CA110041; -- Child Package body Computer_System.Manager diff --git a/gcc/testsuite/ada/acats/tests/ca/ca110042.am b/gcc/testsuite/ada/acats/tests/ca/ca110042.am new file mode 100644 index 000000000..800ed8aae --- /dev/null +++ b/gcc/testsuite/ada/acats/tests/ca/ca110042.am @@ -0,0 +1,130 @@ +-- CA110042.AM +-- +-- Grant of Unlimited Rights +-- +-- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687, +-- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained +-- unlimited rights in the software and documentation contained herein. +-- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making +-- this public release, the Government intends to confer upon all +-- recipients unlimited rights equal to those held by the Government. +-- These rights include rights to use, duplicate, release or disclose the +-- released technical data and computer software in whole or in part, in +-- any manner and for any purpose whatsoever, and to have or permit others +-- to do so. +-- +-- DISCLAIMER +-- +-- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR +-- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED +-- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF 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 private part of a child library unit package can +-- utilize its parent unit's visible definitions. +-- +-- TEST DESCRIPTION: +-- Declare a public library unit package and child package, with the +-- child package having a private part in the specification. Within +-- this child private part, make use of components that are declared in +-- the visible part of the parent. +-- +-- Demonstrate visibility to the following parent components in the +-- child private part: +-- Parent +-- Type X +-- Constant X +-- Object X +-- Subprogram X +-- Exception X +-- +-- +-- TEST FILES: +-- The following files comprise this test: +-- +-- CA110040.A +-- CA110041.A +-- => CA110042.AM +-- +-- +-- CHANGE HISTORY: +-- 06 Dec 94 SAIC ACVC 2.0 +-- +--! +with Report; +with CA110040.CA110041; + +procedure CA110042 is + + package System_Manager renames CA110040.CA110041; + use CA110040; + User1, User2, User3 : System_Manager.User_Account; + +begin + + Report.Test ("CA110042", "Check that the private part of a child " & + "library unit package can utilize its " & + "parent unit's visible definitions"); + + Assign_New_Accounts: -- This code simulates the entering of new + -- user accounts into a computer system. + -- It also simulates the processing that + -- could occur when the limit on system + -- accounts has been exceeded. + + -- This processing block demonstrates the + -- use of child package functionality that + -- takes advantage of components declared in + -- the parent package. + begin + + if Total_Accounts /= 2 then + Report.Failed ("Incorrect number of accounts currently allocated"); + end if; -- At this point, both + -- System_Account and + -- Auditor_Account have + -- been declared and + -- initialized in package + -- CA110040.CA110041. + + System_Manager.Initialize_User_Account (User1); -- User_ID has been + -- set to 3. + + System_Manager.Initialize_User_Account (User2); -- User_ID has been + -- set to 4, which + -- is the last value + -- defined for the + -- CA110040.ID_Type + -- range. + + System_Manager.Initialize_User_Account (User3); -- This final call will + -- result in an + -- Account_Limit_Exceeded + -- exception being raised. + + Report.Failed ("Control should have transferred with exception"); + + exception + + when Account_Limit_Exceeded => + if (not (Administrator_Account.User_ID = ID_Type'First)) or + (User2.User_ID /= CA110040.ID_Type'Last) + then + Report.Failed ("Account initialization failure"); + end if; + when others => + Report.Failed ("Unexpected exception raised"); + + end Assign_New_Accounts; + + if (User1.User_ID /= 3) or (User2.User_ID /= 4) then + Report.Failed ("Improper initialization of user accounts"); + end if; + + Report.Result; + +end CA110042; diff --git a/gcc/testsuite/ada/acats/tests/ca/ca110050.a b/gcc/testsuite/ada/acats/tests/ca/ca110050.a new file mode 100644 index 000000000..88455762c --- /dev/null +++ b/gcc/testsuite/ada/acats/tests/ca/ca110050.a @@ -0,0 +1,99 @@ +-- CA110050.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: +-- See CA110051.AM +-- +-- TEST DESCRIPTION: +-- See CA110051.AM +-- +-- TEST FILES: +-- The test consists of the following files: +-- +-- => CA110050.A +-- CA110051.AM +-- +-- CHANGE HISTORY: +-- 06 Dec 94 SAIC ACVC 2.0 +-- 21 Dec 94 SAIC Modified discriminant type +-- 26 Apr 96 SAIC ACVC 2.1: Modified prologue; Added pragma +-- Elaborate_Body. +-- +--! + +package CA110050_0 is -- Package Messages. + pragma Elaborate_Body (CA110050_0); + + type Descriptor is new Integer; + + Null_Descriptor_Value : constant Descriptor := 0; + Null_Message_Descriptor : constant Descriptor := 0; + + type Message_Type is tagged + record + Number : Descriptor := Null_Message_Descriptor; + end record; + + function Next_Available_Message return Descriptor; + +end CA110050_0; -- Package Messages. + + --=================================================================-- + +package body CA110050_0 is -- Package body Messages. + + Message_Count : Integer := 0; + + function Next_Available_Message return Descriptor is + begin + Message_Count := Message_Count + 5; + return (Descriptor(Message_Count)); + end Next_Available_Message; + +end CA110050_0; -- Package body Messages. + + --=================================================================-- + +package CA110050_0.CA110050_1 is -- Child package Messages.Text + + subtype Default_Length is Natural range 0 .. 80; + + type Text_Type (Max_Length : Default_Length := 0) is + record + Length : Default_Length := Max_Length; + Text_Field : String (1 .. Max_Length); + end record; + + type Text_Message_Type is new Message_Type with + record + Text : Text_Type; + end record; + + Null_Text : Text_Type (0); -- Null range for + -- Text_Field component. + +end CA110050_0.CA110050_1; -- Child package Messages.Text +-- +-- No package body needed for this specification. diff --git a/gcc/testsuite/ada/acats/tests/ca/ca110051.am b/gcc/testsuite/ada/acats/tests/ca/ca110051.am new file mode 100644 index 000000000..91af06823 --- /dev/null +++ b/gcc/testsuite/ada/acats/tests/ca/ca110051.am @@ -0,0 +1,224 @@ +-- CA110051.AM +-- +-- Grant of Unlimited Rights +-- +-- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687, +-- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained +-- unlimited rights in the software and documentation contained herein. +-- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making +-- this public release, the Government intends to confer upon all +-- recipients unlimited rights equal to those held by the Government. +-- These rights include rights to use, duplicate, release or disclose the +-- released technical data and computer software in whole or in part, in +-- any manner and for any purpose whatsoever, and to have or permit others +-- to do so. +-- +-- DISCLAIMER +-- +-- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR +-- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED +-- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF 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 entities and operations declared in a package can be used +-- in the private part of a child of a child of the package. +-- +-- TEST DESCRIPTION: +-- Declare a series of library unit packages -- parent, child, and +-- grandchild. The grandchild package will have a private part. +-- From within the private part of the grandchild, make use of +-- components declared in the parent and grandparent packages. +-- +-- TEST FILES: +-- The test consists of the following files: +-- +-- CA110050.A +-- => CA110051.AM +-- +-- +-- CHANGE HISTORY: +-- 06 Dec 94 SAIC ACVC 2.0 +-- +--! + + -- Grandchild Package Message.Text.Encoded +package CA110050_0.CA110050_1.CA110050_2 is + + type Coded_Message is new Text_Message_Type with private; + + procedure Send (Message : in Coded_Message; + Confirm : out Coded_Message; + Status : out Boolean); + + function Encode (Message : Text_Message_Type) return Coded_Message; + function Decode (Message : Coded_Message) return Boolean; + function Test_Connection return Boolean; + +private + + Uncoded : Descriptor renames Null_Descriptor_Value; -- Grandparent object. + + type Coded_Message is new Text_Message_Type with -- Parent type. + record + Key : Descriptor := Uncoded; + Coded_Key : Descriptor := Next_Available_Message; + -- Grandparent type, grandparent function. + Scrambled : Text_Type := Null_Text; -- Parent object. + end record; + + Coded_Msg : Coded_Message; + + type Blank_Message is new Message_Type with -- Grandparent type. + record + ID : Descriptor := Next_Available_Message; + -- Grandparent type, grandparent function. + end record; + + Test_Message : Blank_Message; + + Confirm_String : constant String := "OK"; + Scrambled_String : constant String := "KO"; + + Confirm_Text : Text_Type (Confirm_String'Length) := + (Max_Length => Confirm_String'Length, + Length => Confirm_String'Length, + Text_Field => Confirm_String); + + Scrambled_Text : Text_Type (Scrambled_String'Length) := + (Max_Length => Scrambled_String'Length, + Length => Scrambled_String'Length, + Text_Field => Scrambled_String); + +end CA110050_0.CA110050_1.CA110050_2; -- Grandchild Pkg Message.Text.Encoded + + --=================================================================-- + + -- Grandchild Package body Message.Text.Encoded +package body CA110050_0.CA110050_1.CA110050_2 is + + procedure Send (Message : in Coded_Message; + Confirm : out Coded_Message; + Status : out Boolean) is + + Confirmation_Message : Coded_Message := + (Number => Message.Number, + Text => Confirm_Text, + Key => Message.Number, + Coded_Key => Message.Number, + Scrambled => Scrambled_Text); + + begin -- Dummy processing unit. + Confirm := Confirmation_Message; + if Confirm.Number /= Null_Message_Descriptor then + Status := True; + else + Status := False; + end if; + end Send; + ------------------------------------------------------------------------- + function Encode (Message : Text_Message_Type) return Coded_Message is + begin + Coded_Msg.Number := Message.Number; + if Message.Text.Length > 0 then + Coded_Msg.Text := Message.Text; -- Record assignment. + Coded_Msg.Key := Message.Number; -- Same as msg number. + Coded_Msg.Coded_Key := Message.Number; -- Same as msg number. + Coded_Msg.Scrambled := Message.Text; -- Dummy processing. + end if; + return (Coded_Msg); + end Encode; + ------------------------------------------------------------------------- + function Decode (Message : Coded_Message) return Boolean is + Decoded : Boolean := False; + begin + if (Message.Text.Length = Confirm_String'Length) and then + (Message.Text.Text_Field = Confirm_String) and then + (Message.Scrambled.Length = Scrambled_String'Length) and then + (Message.Scrambled.Text_Field = Scrambled_String) and then + (Message.Coded_Key = 15) + then + Decoded := True; + end if; + return (Decoded); + end Decode; + ------------------------------------------------------------------------- + function Test_Connection return Boolean is + begin + return Test_Message.Id = 10; + end Test_Connection; + +end CA110050_0.CA110050_1.CA110050_2; + -- Grandchild Package body Message.Text.Encoded + + --=================================================================-- + +with CA110050_0.CA110050_1.CA110050_2; +with Report; + +procedure CA110051 is + + package Message_Package renames CA110050_0.CA110050_1; + package Code_Package renames CA110050_0.CA110050_1.CA110050_2; + + Message_String : constant String := "One if by land, two if by sea"; + + Message_Text : Message_Package.Text_Type (Message_String'Length) := + (Max_Length => Message_String'Length, + Length => Message_String'Length, + Text_Field => Message_String); + + Message : Message_Package.Text_Message_Type := + (Number => CA110050_0.Next_Available_Message, + Text => Message_Text); + + Confirmation_Message : Code_Package.Coded_Message; + Verification_OK : Boolean := False; + Transmission_OK : Boolean := False; + +begin + +-- This test simulates the use of child library unit packages to implement +-- a message encoding and transmission scheme. The full capability of the +-- encoding and transmission mechanisms are not developed here, but the +-- intent is to demonstrate that a grandchild library unit package with a +-- private part will provide the framework for this type of processing. + + Report.Test ("CA110051", "Check that entities and operations declared " & + "in a package can be used in the private part " & + "of a child of a child of the package"); + + -- The following code demonstrates the use + -- of functionality contained in a grandchild + -- library unit. The grandchild unit made use + -- of components declared in the ancestor + -- packages. + + Code_Package.Send -- Message object declared + (Message => Code_Package.Encode (Message), -- above in "encoded" by a + Confirm => Confirmation_Message, -- call to grandchild pkg + Status => Transmission_OK); -- function call, reseting + -- fields and returning a + -- coded message to the + -- parameter. The confirm + -- parameter receives an + -- encoded message value + -- from proc Send, which is + -- "decoded"/verified below. + + if not Code_Package.Test_Connection then + Report.Failed ("Bad initialization"); + end if; + + Verification_OK := Code_Package.Decode (Confirmation_Message); + + if not (Transmission_OK and Verification_OK) then + Report.Failed ("Message transmission failure"); + end if; + + Report.Result; + +end CA110051; diff --git a/gcc/testsuite/ada/acats/tests/ca/ca11006.a b/gcc/testsuite/ada/acats/tests/ca/ca11006.a new file mode 100644 index 000000000..5cd21fe1f --- /dev/null +++ b/gcc/testsuite/ada/acats/tests/ca/ca11006.a @@ -0,0 +1,211 @@ +-- CA11006.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 private part of a child library unit can utilize +-- its parent unit's private definition. +-- +-- TEST DESCRIPTION: +-- Declare a package and public child package, both with private +-- parts. The child package will have a private extension of a type +-- declared in the parent's private part. In addition, the private +-- part of the child package specification will make use of some of +-- the components declared in the private part of the parent. +-- +-- +-- CHANGE HISTORY: +-- 06 Dec 94 SAIC ACVC 2.0 +-- 15 Nov 95 SAIC Update and repair for ACVC 2.0.1 +-- +--! + +package CA11006_0 is -- Package File_Package + + type File_Descriptor is private; + type File_Mode is (Read_Only, Write_Only, Read_Write); + type File_Type is tagged private; + + function Next_Available_File return File_Descriptor; + +private + + type File_Measure is range 0 .. 1000; + type File_Descriptor is new Integer; + + Null_File : constant File_Descriptor := 0; + Default_Mode : constant File_Mode := Read_Write; + + type File_Type is tagged + record + Descriptor : File_Descriptor := Null_File; + Mode : File_Mode := Default_Mode; + end record; + + System_File : File_Type; + +end CA11006_0; -- Package File_Package + + --=================================================================-- + +package body CA11006_0 is -- Package File_Package + + File_Count : Integer := 0; + + function Next_Available_File return File_Descriptor is + begin + File_Count := File_Count + 1; + return File_Descriptor (File_Count); + end Next_Available_File; + +end CA11006_0; -- Package File_Package + + --=================================================================-- + +package CA11006_0.CA11006_1 is -- Child package File_Package.Operations + + type File_Length_Type is private; + type Extended_File_Type is new File_Type with private; + + System_Extended_File : constant Extended_File_Type; + + procedure Create_File (Mode : in File_Mode; + File : out Extended_File_Type); + + procedure Compress_File (Original : in Extended_File_Type; + Compressed_File : out Extended_File_Type); + + function Validate (File : in Extended_File_Type) return Boolean; + + function Validate_Compression (File : in Extended_File_Type) + return Boolean; + -- These two validation functions provide + -- the capability to check the private + -- components defined in the parent and + -- child packages from within the client + -- program. +private + + type File_Length_Type is new File_Measure; -- Parent private type. + + Min_File_Size : File_Length_Type := File_Length_Type'First; + Max_File_Size : File_Length_Type := File_Length_Type'Last; + + type Extended_File_Type is new File_Type with -- Parent type. + record + Blocks : File_Length_Type := Min_File_Size; + end record; + + System_Extended_File : constant Extended_File_Type := + (Descriptor => System_File.Descriptor, -- Parent private object. + Mode => Read_Only, -- Parent enumeration literal. + Blocks => Min_File_Size); + + +end CA11006_0.CA11006_1; -- Child Package File_Package.Operations + + --=================================================================-- + + -- Child package body File_Package.Operations +package body CA11006_0.CA11006_1 is + + procedure Create_File + (Mode : in File_Mode; + File : out Extended_File_Type) is + begin + File.Descriptor := Next_Available_File; -- Parent subprogram. + File.Mode := Default_Mode; -- Parent private constant. + File.Blocks := Max_File_Size; + end Create_File; + ------------------------------------------------------------------------ + procedure Compress_File (Original : in Extended_File_Type; + Compressed_File : out Extended_File_Type) is + begin + Compressed_File.Descriptor := Next_Available_File; + Compressed_File.Mode := Read_Only; + Compressed_File.Blocks := Original.Blocks / 2; -- Simulated file + end Compress_File; -- compression. + ------------------------------------------------------------------------ + function Validate (File : in Extended_File_Type) return Boolean is + begin + if ((File.Descriptor /= System_Extended_File.Descriptor) and + (File.Mode = Read_Write) and + (File.Blocks = Max_File_Size)) then + return True; + else + return False; + end if; + end Validate; + ------------------------------------------------------------------------ + function Validate_Compression (File : in Extended_File_Type) + return Boolean is + begin + if ((File.Descriptor /= System_File.Descriptor) and + (File.Mode = Read_Only) and + (File.Blocks = Max_File_Size/2)) then + return True; + else + return False; + end if; + end Validate_Compression; + +end CA11006_0.CA11006_1; -- Child package body File_Package.Operations + + --=================================================================-- + +with CA11006_0.CA11006_1; -- with Child package File_Package.Operations +with Report; + +procedure CA11006 is + + package File renames CA11006_0; + package File_Ops renames CA11006_0.CA11006_1; + + Validation_File_Mode : File.File_Mode := File.Read_Only; + Validation_File, + Storage_Copy : File_Ops.Extended_File_Type; + +begin + + Report.Test ("CA11006", "Check that the private part of a child " & + "library unit can utilize its parent " & + "unit's private definition"); + + File_Ops.Create_File (Validation_File_Mode, Validation_File); + + if not File_Ops.Validate (Validation_File) then + Report.Failed ("Incorrect initialization of file"); + end if; + + File_Ops.Compress_File (Validation_File, Storage_Copy); + + if not (File_Ops.Validate (Validation_File) and + File_Ops.Validate_Compression (Storage_Copy)) + then + Report.Failed ("Incorrect compression of file"); + end if; + + Report.Result; + +end CA11006; diff --git a/gcc/testsuite/ada/acats/tests/ca/ca11007.a b/gcc/testsuite/ada/acats/tests/ca/ca11007.a new file mode 100644 index 000000000..c4a6789ab --- /dev/null +++ b/gcc/testsuite/ada/acats/tests/ca/ca11007.a @@ -0,0 +1,228 @@ +-- CA11007.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 private part of a grandchild library unit can +-- utilize its grandparent unit's private definition. +-- +-- TEST DESCRIPTION: +-- Declare a package, child package, and grandchild package, all +-- with private parts in their specifications. +-- +-- The private part of the grandchild package will make use of components +-- that have been declared in the private part of the grandparent +-- specification. +-- +-- The child package demonstrates the extension of a parent file type +-- into an abstraction of an analog file structure. The grandchild package +-- extends the grandparent file type into an abstraction of a digital +-- file structure, and provides conversion capability to/from the parent +-- analog file structure. +-- +-- +-- CHANGE HISTORY: +-- 06 Dec 94 SAIC ACVC 2.0 +-- +--! + +package CA11007_0 is -- Package File_Package + + type File_Descriptor is private; + type File_Type is tagged private; + + function Next_Available_File return File_Descriptor; + +private + + type File_Measure_Type is range 0 .. 1000; + type File_Descriptor is new Integer; + + Null_Measure : constant File_Measure_Type := File_Measure_Type'First; + Null_File : constant File_Descriptor := 0; + + type File_Type is tagged + record + Descriptor : File_Descriptor := Null_File; + end record; + +end CA11007_0; -- Package File_Package + + --=================================================================-- + +package body CA11007_0 is -- Package body File_Package + + File_Count : Integer := 0; + + function Next_Available_File return File_Descriptor is + begin + File_Count := File_Count + 1; + return File_Descriptor (File_Count); + end Next_Available_File; + +end CA11007_0; -- Package body File_Package + + --=================================================================-- + +package CA11007_0.CA11007_1 is -- Child package Analog + + type Analog_File_Type is new File_Type with private; + +private + + type Wavelength_Type is new File_Measure_Type; + + Min_Wavelength : constant Wavelength_Type := Wavelength_Type'First; + + type Analog_File_Type is new File_Type with -- Parent type. + record + Wavelength : Wavelength_Type := Min_Wavelength; + end record; + +end CA11007_0.CA11007_1; -- Child package Analog + + --=================================================================-- + +package CA11007_0.CA11007_1.CA11007_2 is -- Grandchild package Digital + + type Digital_File_Type is new File_Type with private; + + procedure Recording (File : out Digital_File_Type); + + procedure Convert (From : in Analog_File_Type; + To : out Digital_File_Type); + + function Validate (File : in Digital_File_Type) return Boolean; + function Valid_Conversion (To : Digital_File_Type) return Boolean; + function Valid_Initial (From : Analog_File_Type) return Boolean; + +private + + type Track_Type is new File_Measure_Type; -- Grandparent type. + + Min_Tracks : constant Track_Type := + Track_Type (Null_Measure) + Track_Type'First; -- Grandparent private + Max_Tracks : constant Track_Type := -- constant. + Track_Type (Null_Measure) + Track_Type'Last; + + type Digital_File_Type is new File_Type with -- Grandparent type. + record + Tracks : Track_Type := Min_Tracks; + end record; + +end CA11007_0.CA11007_1.CA11007_2; -- Grandchild package Digital + + --=================================================================-- + + -- Grandchild package body Digital +package body CA11007_0.CA11007_1.CA11007_2 is + + procedure Recording (File : out Digital_File_Type) is + begin + File.Descriptor := Next_Available_File; -- Assign new file descriptor. + File.Tracks := Max_Tracks; -- Change initial value. + end Recording; + -------------------------------------------------------------------------- + procedure Convert (From : in Analog_File_Type; + To : out Digital_File_Type) is + begin + To.Descriptor := From.Descriptor + 100; -- Dummy conversion. + To.Tracks := Track_Type (From.Wavelength) / 2; + end Convert; + -------------------------------------------------------------------------- + function Validate (File : in Digital_File_Type) return Boolean is + Result : Boolean := False; + begin + if not (File.Tracks /= Max_Tracks) then + Result := True; + end if; + return Result; + end Validate; + -------------------------------------------------------------------------- + function Valid_Conversion (To : Digital_File_Type) return Boolean is + begin + return (To.Descriptor = 100) and (To.Tracks = (Min_Tracks / 2)); + end Valid_Conversion; + -------------------------------------------------------------------------- + function Valid_Initial (From : Analog_File_Type) return Boolean is + begin + return (From.Wavelength = Min_Wavelength); -- Validate initial + end Valid_Initial; -- conditions. + +end CA11007_0.CA11007_1.CA11007_2; -- Grandchild package body Digital + + --=================================================================-- + +with CA11007_0.CA11007_1.CA11007_2; -- with Grandchild package Digital +with Report; + +procedure CA11007 is + + package Analog renames CA11007_0.CA11007_1; + package Digital renames CA11007_0.CA11007_1.CA11007_2; + + Original_Digital_File, + Converted_Digital_File : Digital.Digital_File_Type; + + Original_Analog_File : Analog.Analog_File_Type; + +begin + + -- This code demonstrates how private extensions could be utilized + -- in child packages to allow for recording on different media. + -- The processing contained in the procedures and functions is + -- "dummy" processing, not intended to perform actual recording, + -- conversion, or validation operations, but simply to demonstrate + -- this type of structural decomposition as a possible solution to + -- a user's design problem. + + Report.Test ("CA11007", "Check that the private part of a grandchild " & + "library unit can utilize its grandparent " & + "unit's private definition"); + + if not Digital.Valid_Initial (Original_Analog_File) + then + Report.Failed ("Incorrect initialization of Analog File"); + end if; + + --- + + Digital.Convert (From => Original_Analog_File, -- Convert file to + To => Converted_Digital_File); -- digital format. + + if not Digital.Valid_Conversion (To => Converted_Digital_File) then + Report.Failed ("Incorrect conversion of analog file"); + end if; + + --- + + Digital.Recording (Original_Digital_File); -- Create file in + -- digital format. + if not Digital.Validate (Original_Digital_File) then + Report.Failed ("Incorrect recording of digital file"); + end if; + + Report.Result; + +end CA11007; diff --git a/gcc/testsuite/ada/acats/tests/ca/ca11008.a b/gcc/testsuite/ada/acats/tests/ca/ca11008.a new file mode 100644 index 000000000..1161fbe0c --- /dev/null +++ b/gcc/testsuite/ada/acats/tests/ca/ca11008.a @@ -0,0 +1,216 @@ +-- CA11008.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 private child package can use entities declared in the +-- visible part of its parent unit. +-- +-- TEST DESCRIPTION: +-- Declare a parent package containing types and objects used +-- by the system. Declare a private child package that uses the parent +-- components to provide functionality to the system. +-- +-- The tagged file type defined in the parent has defaults for all +-- component fields. Prior to initialization, these values are checked +-- to ensure a correct start condition. The initial subprogram is +-- called, which utilizes the functionality provided in the private +-- child package. This subprogram changes the fields of the file object +-- to something other than the default values, and this process is then +-- verified at the conclusion of the test. +-- +-- +-- CHANGE HISTORY: +-- 06 Dec 94 SAIC ACVC 2.0 +-- +--! + +package CA11008_0 is -- Package OS. + + type File_Descriptor_Type is new Integer; + type File_Name_Type is new String (1 .. 11); + type Permission_Type is (None, User, System, Bypass); + type File_Mode_Type is (Read_Only, Write_Only, Read_Write); + type File_Status_Type is (Open, Closed); + + Default_Descriptor : constant File_Descriptor_Type := 0; + Default_Permission : constant Permission_Type := None; + Default_Mode : constant File_Mode_Type := Read_Only; + Default_Status : constant File_Status_Type := Closed; + Default_Filename : constant File_Name_Type := " "; + + Max_Files : constant File_Descriptor_Type := 100; + Constant_Name : constant File_Name_Type := "AdaFileName"; + File_Counter : Integer := 0; + + type File_Type is tagged + record + Descriptor : File_Descriptor_Type := Default_Descriptor; + Name : File_Name_Type := Default_Filename; + Acct_Access : Permission_Type := Default_Permission; + Mode : File_Mode_Type := Default_Mode; + Current_Status : File_Status_Type := Default_Status; + end record; + + type File_Array_Type is array (1 .. Max_Files) of File_Type; + + File_Table : File_Array_Type; + + -- + + function Get_File_Name return File_Name_Type; + + function Initialize_File return File_Descriptor_Type; + +end CA11008_0; -- Package OS. + + --=================================================================-- + +-- Subprograms that perform the actual file operations are contained in a +-- private package so that they are not accessible to any client. + +private package CA11008_0.CA11008_1 is -- Package OS.Internals + + Private_File_Counter : Integer renames File_Counter; -- Parent + -- object. + function Initialize + (File_Name : File_Name_Type := Get_File_Name; -- Parent function. + File_Mode : File_Mode_Type := Read_Write) -- Parent literal. + return File_Descriptor_Type; -- Parent type. + +end CA11008_0.CA11008_1; -- Package OS.Internals + + --=================================================================-- + +package body CA11008_0.CA11008_1 is -- Package body OS.Internals + + function Next_Available_File return File_Descriptor_Type is + begin + Private_File_Counter := Private_File_Counter + 1; + return (File_Descriptor_Type(File_Counter)); + end Next_Available_File; + ----------------------------------------------------------------- + function Initialize + (File_Name : File_Name_Type := Get_File_Name; -- Parent function + File_Mode : File_Mode_Type := Read_Write) -- Parent literal + return File_Descriptor_Type is -- Parent type + Number : File_Descriptor_Type; + begin + Number := Next_Available_File; + File_Table(Number).Descriptor := Number; -- Parent object + File_Table(Number).Name := File_Name; -- Default parameter value + File_Table(Number).Mode := File_Mode; -- Default parameter value + File_Table(Number).Acct_Access := User; + File_Table(Number).Current_Status := Open; + return (Number); + end Initialize; + +end CA11008_0.CA11008_1; -- Package body OS.Internals + + --=================================================================-- + +with CA11008_0.CA11008_1; -- Private child package "withed" by + -- parent body. + +package body CA11008_0 is -- Package body OS + + function Get_File_Name return File_Name_Type is + begin + return (Constant_Name); -- Of course if this was a real function, the + end Get_File_Name; -- user would be asked to input a name, or + -- there would be some type of similar process. + + -- This subprogram utilizes a call to a subprogram contained in a private + -- child to perform the actual processing. + + function Initialize_File return File_Descriptor_Type is + begin + return (CA11008_0.CA11008_1.Initialize); -- No parameters are needed, + -- since defaults have been + -- provided. + end Initialize_File; + +end CA11008_0; -- Package body OS + + --=================================================================-- + +with CA11008_0; -- with Package OS. +with Report; + +procedure CA11008 is + + package OS renames CA11008_0; + use OS; + Ada_File_Key : File_Descriptor_Type := Default_Descriptor; + +begin + + -- This test indicates one approach to file management operations. + -- It is not intended to demonstrate full functionality, but rather + -- that the use of a private child package can provide a solution + -- to a user situation, that being the implementation of certain functions + -- being provided in a child package, with the parent package body + -- utilizing these implementations. + + Report.Test ("CA11008", "Check that a private child package can use " & + "entities declared in the visible part of its " & + "parent unit"); + + -- Check initial conditions of the first entry in the file table. + -- These are all default values provided in the declaration of the + -- type File_Type. + + if (Ada_File_Key /= Default_Descriptor) or else + (File_Table(1).Descriptor /= (Default_Descriptor) or + (File_Table(1).Name /= Default_Filename)) or else + (File_Table(1).Acct_Access /= (Default_Permission) or + (File_Table(1).Mode /= Default_Mode)) or else + (File_Table(1).Current_Status /= Default_Status) + then + Report.Failed ("Initial condition failure"); + end if; + + -- Call the initialization function. This will result in the resetting + -- of the fields associated with the first entry in the File_Table (this + -- is the first call of Initialize_File). + -- No parameters are necessary for this call, due to the default values + -- provided in the private child package routine Initialize. + + Ada_File_Key := Initialize_File; + + -- Verify that the initial conditions of the file table component have + -- been properly modified by the initialization function. + + if not ((File_Table(1).Descriptor = Ada_File_Key) and then + (File_Table(1).Name = Constant_Name) and then + (File_Table(1).Acct_Access = User) and then + not ((File_Table(1).Mode = Default_Mode) or else + (File_Table(1).Current_Status = Default_Status))) + then + Report.Failed ("Initialization processing failure"); + end if; + + Report.Result; + +end CA11008; diff --git a/gcc/testsuite/ada/acats/tests/ca/ca11009.a b/gcc/testsuite/ada/acats/tests/ca/ca11009.a new file mode 100644 index 000000000..84d7dc2b3 --- /dev/null +++ b/gcc/testsuite/ada/acats/tests/ca/ca11009.a @@ -0,0 +1,246 @@ +-- CA11009.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 private child package can use entities declared in the +-- visible part of the parent unit of its parent unit. +-- +-- TEST DESCRIPTION: +-- Declare a parent package containing types and objects used by the +-- system. Declare a public child package that provides a visible +-- interface to the system functionality. +-- Declare a private grandchild package that uses the visible grandparent +-- components to provide the actual functionality to the system. +-- +-- The public child (parent of the private grandchild) uses the +-- functionality of its private child (grandchild package) to provide +-- the visible interface to operations of the system. +-- +-- The test itself will utilize the visible interface provided in the +-- public child package to demonstrate a possible structure for +-- file management. +-- +-- +-- CHANGE HISTORY: +-- 06 Dec 94 SAIC ACVC 2.0 +-- 15 Apr 96 SAIC ACVC 2.1: Added pragma Elaborate_body. +-- +--! + +package CA11009_0 is -- Package OS. + pragma Elaborate_Body (CA11009_0); + + type File_Descriptor_Type is new Integer; + type File_Name_Type is new String (1 .. 11); + type Permission_Type is (None, User, System, Bypass); + type File_Mode_Type is (Read_Only, Write_Only, Read_Write); + type File_Status_Type is (Open, Closed); + + Default_Descriptor : constant File_Descriptor_Type := 0; + Default_Permission : constant Permission_Type := None; + Default_Mode : constant File_Mode_Type := Read_Only; + Default_Status : constant File_Status_Type := Closed; + Default_Filename : constant File_Name_Type := " "; + + Max_Files : constant File_Descriptor_Type := 10; + An_Ada_File_Name : constant File_Name_Type := "AdaFileName"; + File_Counter : Integer := 0; + + type File_Type is tagged + record + Descriptor : File_Descriptor_Type := Default_Descriptor; + Name : File_Name_Type := Default_Filename; + Acct_Access : Permission_Type := Default_Permission; + Mode : File_Mode_Type := Default_Mode; + Current_Status : File_Status_Type := Default_Status; + end record; + + type File_Array_Type is array (1 .. Max_Files) of File_Type; + + File_Table : File_Array_Type; + + -- + + function Get_File_Name return File_Name_Type; + +end CA11009_0; -- Package OS. + + --=================================================================-- + +package body CA11009_0 is -- Package body OS. + + function Get_File_Name return File_Name_Type is + begin + return (An_Ada_File_Name); -- Processing would be replace by a user + -- prompt in a functioning system. + end Get_File_Name; + +end CA11009_0; -- Package body OS. + + --=================================================================-- + +package CA11009_0.CA11009_1 is -- Child Package OS.File_Manager + + -- This package simulates a visible interface for the Operating System. + -- The actual processing performed by this routine is encapsulated + -- in the routines of private child package Internals, which is "withed" + -- by the body of this package. + + procedure Create_File (Mode : in File_Mode_Type; + File_Key : out File_Descriptor_Type); + +end CA11009_0.CA11009_1; -- Child Package OS.File_Manager + + --=================================================================-- + +-- Subprogram that performs the actual file operation is contained in a +-- private package so that it is not accessible to any client, and can be +-- modified/extended without requiring recompilation of the clients of the +-- parent (since this package is "withed" by the parent body only.) + + + -- Grandchild Package OS.File_Manager.Internals +private package CA11009_0.CA11009_1.CA11009_2 is + + Initial_Permission : constant Permission_Type := User; -- Grandparent + Initial_Status : constant File_Status_Type := Open; -- literals. + Initial_Filename : constant File_Name_Type := -- Grandparent type. + Get_File_Name; -- Grandparent function. + + function Create (Mode : File_Mode_Type) + return File_Descriptor_Type; -- Grandparent type. + +end CA11009_0.CA11009_1.CA11009_2; + -- Grandchild Package OS.File_Manager.Internals + + --=================================================================-- + + -- Grandchild Package body OS.File_Manager.Internals +package body CA11009_0.CA11009_1.CA11009_2 is + + function Next_Available_File return File_Descriptor_Type is + begin + File_Counter := File_Counter + 1; -- Grandparent object. + return (File_Descriptor_Type(File_Counter)); + end Next_Available_File; + ------------------------------------------------------------------------- + function Create (Mode : File_Mode_Type) -- Grandparent literal. + return File_Descriptor_Type is + Number : File_Descriptor_Type; -- Grandparent type. + begin + Number := Next_Available_File; + File_Table(Number).Descriptor := Number; -- Grandparent object. + File_Table(Number).Name := Initial_Filename; + File_Table(Number).Mode := Mode; -- Parameter. + File_Table(Number).Acct_Access := Initial_Permission; + File_Table(Number).Current_Status := Initial_Status; + return (Number); + end Create; + +end CA11009_0.CA11009_1.CA11009_2; + -- Grandchild Package body OS.File_Manager.Internals + + --=================================================================-- + + -- "With" of a child package + -- by the parent body. +with CA11009_0.CA11009_1.CA11009_2; -- Grandchild OS.File_Manager.Internals + +package body CA11009_0.CA11009_1 is -- Child Package body OS.File_Manager + + package Internal renames CA11009_0.CA11009_1.CA11009_2; + + -- These subprograms utilize calls to subprograms contained in a private + -- sibling to perform the actual processing. + + procedure Create_File (Mode : in File_Mode_Type; + File_Key : out File_Descriptor_Type) is + begin + File_Key := Internal.Create (Mode); + end Create_File; + +end CA11009_0.CA11009_1; -- Child Package body OS.File_Manager + + --=================================================================-- + +with CA11009_0.CA11009_1; -- with Child Package OS.File_Manager +with Report; + +procedure CA11009 is + + package OS renames CA11009_0; + use OS; + package File_Manager renames CA11009_0.CA11009_1; + + Data_Base_File_Key : File_Descriptor_Type := Default_Descriptor; + New_Mode : File_Mode_Type := Read_Write; + +begin + + -- This test indicates one approach to file management. + -- It is not intended to demonstrate full functionality, but rather + -- that the use of a private child package could provide a solution + -- to this type of situation. + + Report.Test ("CA11009", "Check that a private child package can use " & + "entities declared in the visible part of the " & + "parent unit of its parent unit"); + + -- Check initial conditions of the first entry in the file table. + -- These are all default values provided in the declaration of the + -- type File_Type. + + if (not (Data_Base_File_Key = Default_Descriptor)) and then + (((not (File_Table(1).Name = Default_Filename)) or + (File_Table(1).Descriptor /= Default_Descriptor)) or else + ((File_Table(1).Acct_Access /= Default_Permission) or + (not (File_Table(1).Mode = Default_Mode)) or + (File_Table(1).Current_Status /= Default_Status))) + then + Report.Failed ("Initial condition failure"); + end if; + + -- Create/initialize file using the capability provided by the visible + -- interface to the operating system, OS.File_Manager. The actual + -- processing routine is contained in the private grandchild package + -- Internals, which utilize the components from the grandparent package. + + File_Manager.Create_File (New_Mode, Data_Base_File_Key); + + -- Verify that the initial conditions of the file table component have + -- been properly modified by the initialization function. + + if not ((File_Table(1).Descriptor = Data_Base_File_Key) and then + (File_Table(1).Name = An_Ada_File_Name) and then + (File_Table(1).Acct_Access = User) and then + not ((File_Table(1).Mode = Default_Mode) or else + (File_Table(1).Current_Status = Default_Status))) + then + Report.Failed ("File creation failure"); + end if; + + Report.Result; + +end CA11009; diff --git a/gcc/testsuite/ada/acats/tests/ca/ca11010.a b/gcc/testsuite/ada/acats/tests/ca/ca11010.a new file mode 100644 index 000000000..b13efd798 --- /dev/null +++ b/gcc/testsuite/ada/acats/tests/ca/ca11010.a @@ -0,0 +1,254 @@ +-- CA11010.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 private child package can use entities declared in the +-- private part of its parent unit. +-- +-- TEST DESCRIPTION: +-- Declare a parent package containing private types, objects, +-- and functions used by the system. Declare a private child package that +-- uses the parent components to provide functionality to the system. +-- +-- Declare an array of files with default values for all +-- component fields of the files (records). Check the initial state of +-- a specified file for proper default values. Perform the file "creation" +-- (initialization), which will modify the fields of the record object. +-- Again verify the file object to determine whether the fields have been +-- reset properly. +-- +-- +-- CHANGE HISTORY: +-- 06 Dec 94 SAIC ACVC 2.0 +-- + +package CA11010_0 is -- Package OS. + + type File_Descriptor_Type is private; + + Default_Descriptor : constant File_Descriptor_Type; + + function Initialize_File return File_Descriptor_Type; + procedure Verify_Initial_Conditions (Status : out Boolean); + function Final_Conditions_Valid return Boolean; + +private + + type File_Descriptor_Type is new Integer; + type File_Name_Type is new String (1 .. 11); + type Permission_Type is (None, User, System); + type File_Mode_Type is (Read_Only, Write_Only, Read_Write); + type File_Status_Type is (Open, Closed); + + Default_Descriptor : constant File_Descriptor_Type := 0; + Default_Permission : constant Permission_Type := None; + Default_Mode : constant File_Mode_Type := Read_Only; + Default_Status : constant File_Status_Type := Closed; + Default_Filename : constant File_Name_Type := " "; + An_Ada_File_Name : constant File_Name_Type := "AdaFileName"; + Max_Files : constant File_Descriptor_Type := 100; + + type File_Type is tagged + record + Descriptor : File_Descriptor_Type := Default_Descriptor; + Name : File_Name_Type := Default_Filename; + Acct_Access : Permission_Type := Default_Permission; + Mode : File_Mode_Type := Default_Mode; + Current_Status : File_Status_Type := Default_Status; + end record; + + type File_Array_Type is array (1 .. Max_Files) of File_Type; + + File_Table : File_Array_Type; + File_Counter : Integer := 0; + + -- + + function Get_File_Name return File_Name_Type; + +end CA11010_0; -- Package OS. + + --=================================================================-- + +-- Subprograms that perform the actual file operations are contained in a +-- private package so that they are not accessible to any client. + +private package CA11010_0.CA11010_1 is -- Package OS.Internals + + Private_File_Counter : Integer renames File_Counter; -- Parent priv. object. + + function Initialize + (File_Name : File_Name_Type := Get_File_Name; -- Parent priv. function. + File_Mode : File_Mode_Type := Read_Write) -- Parent priv. literal. + return File_Descriptor_Type; -- Parent type. + +end CA11010_0.CA11010_1; -- Package OS.Internals + + --=================================================================-- + +package body CA11010_0.CA11010_1 is -- Package body OS.Internals + + function Next_Available_File return File_Descriptor_Type is + begin + Private_File_Counter := Private_File_Counter + 1; + return (File_Descriptor_Type(File_Counter)); + end Next_Available_File; + ---------------------------------------------------------------- + function Initialize + (File_Name : File_Name_Type := Get_File_Name; -- Parent priv. function + File_Mode : File_Mode_Type := Read_Write) -- Parent priv. literal + return File_Descriptor_Type is -- Parent type + Number : File_Descriptor_Type; + begin + Number := Next_Available_File; + File_Table(Number).Descriptor := Number; -- Parent priv. object + File_Table(Number).Name := File_Name; -- Default parameter value + File_Table(Number).Mode := File_Mode; -- Default parameter value + File_Table(Number).Acct_Access := User; + File_Table(Number).Current_Status := Open; + return (Number); + end Initialize; + +end CA11010_0.CA11010_1; -- Package body OS.Internals + + --=================================================================-- + +with CA11010_0.CA11010_1; -- Private child package "withed" by + -- parent body. + +package body CA11010_0 is -- Package body OS + + function Get_File_Name return File_Name_Type is + begin + return (An_Ada_File_Name); -- If this was a real function, the user + end Get_File_Name; -- would be asked to input a name, or there + -- would be some type of similar processing. + + -- This subprogram utilizes a call to a subprogram contained in a private + -- child to perform the actual processing. + + function Initialize_File return File_Descriptor_Type is + begin + return (CA11010_0.CA11010_1.Initialize); -- No parameters are needed, + -- since defaults have been + -- provided. + end Initialize_File; + + -- + -- Separate subunits. + -- + + procedure Verify_Initial_Conditions (Status : out Boolean) is separate; + + function Final_Conditions_Valid return Boolean is separate; + +end CA11010_0; -- Package body OS + + --=================================================================-- + +separate (CA11010_0) +procedure Verify_Initial_Conditions (Status : out Boolean) is +begin + Status := False; + if (File_Table(1).Descriptor = Default_Descriptor) and then + (File_Table(1).Name = Default_Filename) and then + (File_Table(1).Acct_Access = Default_Permission) and then + (File_Table(1).Mode = Default_Mode) and then + (File_Table(1).Current_Status = Default_Status) + then + Status := True; + end if; +end Verify_Initial_Conditions; + + --=================================================================-- + +separate (CA11010_0) +function Final_Conditions_Valid return Boolean is +begin + if ((File_Table(1).Descriptor /= Default_Descriptor) and then + (File_Table(1).Name = An_Ada_File_Name) and then + (File_Table(1).Acct_Access = User) and then + not ((File_Table(1).Mode = Default_Mode) or else + (File_Table(1).Current_Status = Default_Status))) + then + return (True); + else + return (False); + end if; +end Final_Conditions_Valid; + + --=================================================================-- + +with CA11010_0; -- with Package OS. +with Report; + +procedure CA11010 is + + package OS renames CA11010_0; + + Ada_File_Key : OS.File_Descriptor_Type := OS.Default_Descriptor; + Initialization_Status : Boolean := False; + +begin + + -- This test indicates one approach to a file management operation. + -- It is not intended to demonstrate full functionality, but rather + -- that the use of a private child package can provide a solution + -- to a user situation, that being the implementation of certain functions + -- being provided in a child package, with the parent package body + -- utilizing these implementations. + + Report.Test ("CA11010", "Check that a private child package can use " & + "entities declared in the private part of its " & + "parent unit"); + + -- Check initial conditions of the first entry in the file table. + -- These are all default values provided in the declaration of the + -- type File_Type. + + OS.Verify_Initial_Conditions (Initialization_Status); + + if not Initialization_Status then + Report.Failed ("Initial condition failure"); + end if; + + -- Call the initialization function. This will result in the resetting + -- of the fields associated with the first entry in the File_Table (this + -- is the first/only call of Initialize_File). + -- No parameters are necessary for this call, due to the default values + -- provided in the private child package routine Initialize. + + Ada_File_Key := OS.Initialize_File; + + -- Verify that the initial conditions of the file table component have + -- been properly modified by the initialization function. + + if not OS.Final_Conditions_Valid then + Report.Failed ("Initialization processing failure"); + end if; + + Report.Result; + +end CA11010; diff --git a/gcc/testsuite/ada/acats/tests/ca/ca11011.a b/gcc/testsuite/ada/acats/tests/ca/ca11011.a new file mode 100644 index 000000000..a75261dd8 --- /dev/null +++ b/gcc/testsuite/ada/acats/tests/ca/ca11011.a @@ -0,0 +1,271 @@ +-- CA11011.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 private child package can use entities declared in the +-- private part of the parent unit of its parent unit. +-- +-- TEST DESCRIPTION: +-- Declare a parent package containing private types and objects +-- used by the system. Declare a public child package that +-- provides a visible interface to the system functionality. +-- Declare a private grandchild package that uses the visible grandparent +-- components to provide the actual functionality to the system. +-- +-- The public child (parent of the private grandchild) uses the +-- functionality of its private child (grandchild package) to provide +-- the visible interface to operations of the system. +-- +-- The test itself will utilize the visible interface provided in the +-- public child package to demonstrate a possible solution to file +-- management. +-- +-- +-- CHANGE HISTORY: +-- 06 Dec 94 SAIC ACVC 2.0 +-- +--! + +package CA11011_0 is -- Package OS. + + type File_Descriptor_Type is private; + + Default_Descriptor : constant File_Descriptor_Type; + First_File : constant File_Descriptor_Type; + + procedure Verify_Initial_Conditions (Key : in File_Descriptor_Type; + Status : out Boolean); + + function Final_Conditions_Valid (Key : File_Descriptor_Type) + return Boolean; + + +private + + type File_Descriptor_Type is new Integer; + type File_Name_Type is new String (1 .. 11); + type Permission_Type is (None, User, System); + type File_Mode_Type is (Read_Only, Write_Only, Read_Write); + type File_Status_Type is (Open, Closed); + + Default_Descriptor : constant File_Descriptor_Type := 0; + First_File : constant File_Descriptor_Type := 1; + Default_Permission : constant Permission_Type := None; + Default_Mode : constant File_Mode_Type := Read_Only; + Default_Status : constant File_Status_Type := Closed; + Default_Filename : constant File_Name_Type := " "; + + Init_Permission : constant Permission_Type := User; + Init_Mode : constant File_Mode_Type := Read_Write; + Init_Status : constant File_Status_Type := Open; + An_Ada_File_Name : constant File_Name_Type := "AdaFileName"; + + Max_Files : constant File_Descriptor_Type := 10; + + type File_Type is tagged + record + Descriptor : File_Descriptor_Type := Default_Descriptor; + Name : File_Name_Type := Default_Filename; + Acct_Access : Permission_Type := Default_Permission; + Mode : File_Mode_Type := Default_Mode; + Current_Status : File_Status_Type := Default_Status; + end record; + + type File_Array_Type is array (1 .. Max_Files) of File_Type; + + File_Table : File_Array_Type; + File_Counter : Integer := 0; + + -- + + function Get_File_Name return File_Name_Type; + +end CA11011_0; -- Package OS. + + --=================================================================-- + +package body CA11011_0 is -- Package body OS. + + function Get_File_Name return File_Name_Type is + begin + return (An_Ada_File_Name); + end Get_File_Name; + --------------------------------------------------------------------- + procedure Verify_Initial_Conditions (Key : in File_Descriptor_Type; + Status : out Boolean) is + begin + Status := False; + if (File_Table(Key).Descriptor = Default_Descriptor) and then + (File_Table(Key).Name = Default_Filename) and then + (File_Table(Key).Acct_Access = Default_Permission) and then + (File_Table(Key).Mode = Default_Mode) and then + (File_Table(Key).Current_Status = Default_Status) + then + Status := True; + end if; + end Verify_Initial_Conditions; + --------------------------------------------------------------------- + function Final_Conditions_Valid (Key : File_Descriptor_Type) + return Boolean is + begin + if ((File_Table(Key).Descriptor = First_File) and then + (File_Table(Key).Name = An_Ada_File_Name) and then + (File_Table(Key).Acct_Access = Init_Permission) and then + not ((File_Table(Key).Mode = Default_Mode) or else + (File_Table(Key).Current_Status = Default_Status))) + then + return (True); + else + return (False); + end if; + end Final_Conditions_Valid; + +end CA11011_0; -- Package body OS. + + --=================================================================-- + +package CA11011_0.CA11011_1 is -- Package OS.File_Manager + + procedure Create_File (File_Key : in File_Descriptor_Type); + +end CA11011_0.CA11011_1; -- Package OS.File_Manager + + --=================================================================-- + +-- The Subprogram that performs the actual file operations is contained in a +-- private package so that it is not accessible to any client. +-- Default parameters are used in most cases in the subprogram calls, since +-- the caller does not have visibility to these private types. + + -- Package OS.File_Manager.Internals +private package CA11011_0.CA11011_1.CA11011_2 is + + Private_File_Counter : Integer renames File_Counter; -- Grandparent + -- object. + procedure Create + (Key : in File_Descriptor_Type; + File_Name : in File_Name_Type := Get_File_Name; -- Grandparent + -- prvt type, + -- prvt functn. + File_Mode : in File_Mode_Type := Init_Mode; -- Grandparent + -- prvt type, + -- prvt const. + File_Access : in Permission_Type := Init_Permission; -- Grandparent + -- prvt type, + -- prvt const. + File_Status : in File_Status_Type := Init_Status); -- Grandparent + -- prvt type, + -- prvt const. + +end CA11011_0.CA11011_1.CA11011_2; -- Package OS.File_Manager.Internals + + --=================================================================-- + + -- Package Body OS.File_Manager.Internals +package body CA11011_0.CA11011_1.CA11011_2 is + + procedure Create + (Key : in File_Descriptor_Type; + File_Name : in File_Name_Type := Get_File_Name; + File_Mode : in File_Mode_Type := Init_Mode; + File_Access : in Permission_Type := Init_Permission; + File_Status : in File_Status_Type := Init_Status) is + begin + Private_File_Counter := Private_File_Counter + 1; + File_Table(Key).Descriptor := Key; -- Grandparent object. + File_Table(Key).Name := File_Name; + File_Table(Key).Mode := File_Mode; + File_Table(Key).Acct_Access := File_Access; + File_Table(Key).Current_Status := File_Status; + end Create; + +end CA11011_0.CA11011_1.CA11011_2; -- Package body OS.File_Manager.Internals + + --=================================================================-- + +with CA11011_0.CA11011_1.CA11011_2; -- with Child OS.File_Manager.Internals + +package body CA11011_0.CA11011_1 is -- Package body OS.File_Manager + + package Internal renames CA11011_0.CA11011_1.CA11011_2; + + -- This subprogram utilizes a call to a subprogram contained in a private + -- child to perform the actual processing. + + procedure Create_File (File_Key : in File_Descriptor_Type) is + begin + Internal.Create (Key => File_Key); -- Other parameters are defaults, + -- since they are of private types + -- from the parent package. + -- File_Descriptor_Type is private, + -- but declared in visible part of + -- parent spec. + end Create_File; + +end CA11011_0.CA11011_1; -- Package body OS.File_Manager + + --=================================================================-- + +with CA11011_0.CA11011_1; -- with public Child Package OS.File_Manager +with Report; + +procedure CA11011 is + + package OS renames CA11011_0; + package File_Manager renames CA11011_0.CA11011_1; + + Data_Base_File_Key : OS.File_Descriptor_Type := OS.First_File; + TC_Status : Boolean := False; + +begin + + -- This test indicates one approach to file management operations. + -- It is not intended to demonstrate full functionality, but rather + -- that the use of a private child package can provide a solution + -- to a typical user situation. + + Report.Test ("CA11011", "Check that a private child package can use " & + "entities declared in the private part of the " & + "parent unit of its parent unit"); + + OS.Verify_Initial_Conditions (Data_Base_File_Key, TC_Status); + + if not TC_Status then + Report.Failed ("Initial condition failure"); + end if; + + -- Perform file initializations. + + File_Manager.Create_File (File_Key => Data_Base_File_Key); + + TC_Status := OS.Final_Conditions_Valid (Data_Base_File_Key); + + if not TC_Status then + Report.Failed ("Bad status return from Create_File"); + end if; + + Report.Result; + +end CA11011; diff --git a/gcc/testsuite/ada/acats/tests/ca/ca11012.a b/gcc/testsuite/ada/acats/tests/ca/ca11012.a new file mode 100644 index 000000000..071b8f813 --- /dev/null +++ b/gcc/testsuite/ada/acats/tests/ca/ca11012.a @@ -0,0 +1,259 @@ +-- CA11012.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 child package of a library level instantiation +-- of a generic can be the instantiation of a child package of +-- the generic. Check that the child instance can use its parent's +-- declarations and operations, including a formal type of the parent. +-- +-- TEST DESCRIPTION: +-- Declare a generic package which simulates an integer complex +-- abstraction. Declare a generic child package of this package +-- which defines additional complex operations. +-- +-- Instantiate the first generic package, then instantiate the child +-- generic package as a child unit of the first instance. In the main +-- program, check that the operations in both instances perform as +-- expected. +-- +-- +-- CHANGE HISTORY: +-- 06 Dec 94 SAIC ACVC 2.0 +-- 21 Dec 94 SAIC Corrected visibility errors for literals +-- 27 Feb 97 PWB.CTA Added elaboration pragma at package CA11012_3 +--! + +generic -- Complex number abstraction. + type Int_Type is range <>; + +package CA11012_0 is + + -- Simulate a generic complex number support package. Complex numbers + -- are treated as coordinates in the Cartesian plane. + + type Complex_Type is private; + + Zero : constant Complex_Type; -- Real number (0,0). + + function Complex (Real, Imag : Int_Type) -- Create a complex + return Complex_Type; -- number. + + function "-" (Right : Complex_Type) -- Invert a complex + return Complex_Type; -- number. + + function "+" (Left, Right : Complex_Type) -- Add two complex + return Complex_Type; -- numbers. + +private + type Complex_Type is record + Real : Int_Type; + Imag : Int_Type; + end record; + + Zero : constant Complex_Type := (Real => 0, Imag => 0); + +end CA11012_0; + + --==================================================================-- + +package body CA11012_0 is + + function Complex (Real, Imag : Int_Type) return Complex_Type is + begin + return (Real, Imag); + end Complex; + --------------------------------------------------------------- + function "-" (Right : Complex_Type) return Complex_Type is + begin + return (-Right.Real, -Right.Imag); + end "-"; + --------------------------------------------------------------- + function "+" (Left, Right : Complex_Type) return Complex_Type is + begin + return ( (Left.Real + Right.Real, Left.Imag + Right.Imag) ); + end "+"; + +end CA11012_0; + + --==================================================================-- + +-- Generic child of complex number package. Child must be generic since +-- parent is generic. + +generic -- Complex additional operations + +package CA11012_0.CA11012_1 is + + -- More operations on complex number. This child adds a layer of + -- functionality to the parent generic. + + function Real_Part (Complex_No : Complex_Type) + return Int_Type; + + function Imag_Part (Complex_No : Complex_Type) + return Int_Type; + + function "*" (Factor : Int_Type; + C : Complex_Type) return Complex_Type; + + function Vector_Magnitude (Complex_No : Complex_Type) + return Int_Type; + +end CA11012_0.CA11012_1; + + --==================================================================-- + +package body CA11012_0.CA11012_1 is + + function Real_Part (Complex_No : Complex_Type) return Int_Type is + begin + return (Complex_No.Real); + end Real_Part; + --------------------------------------------------------------- + function Imag_Part (Complex_No : Complex_Type) return Int_Type is + begin + return (Complex_No.Imag); + end Imag_Part; + --------------------------------------------------------------- + function "*" (Factor : Int_Type; + C : Complex_Type) return Complex_Type is + Result : Complex_Type := Zero; -- Zero is declared in parent, + -- Complex_Number + begin + for I in 1 .. abs (Factor) loop + Result := Result + C; -- Complex_Number "+" + end loop; + + if Factor < 0 then + Result := - Result; -- Complex_Number "-" + end if; + + return Result; + end "*"; + --------------------------------------------------------------- + function Vector_Magnitude (Complex_No : Complex_Type) + return Int_Type is -- Not a real vector magnitude. + begin + return (Complex_No.Real + Complex_No.Imag); + end Vector_Magnitude; + +end CA11012_0.CA11012_1; + + --==================================================================-- + +package CA11012_2 is + + subtype My_Integer is integer range -100 .. 100; + + -- ... Various other types used by the application. + +end CA11012_2; + +-- No body for CA11012_2; + + --==================================================================-- + +-- Declare instances of the generic complex packages for integer type. +-- The instance of the child must itself be declared as a child of the +-- instance of the parent. + +with CA11012_0; -- Complex number abstraction +with CA11012_2; -- Package containing integer type +pragma Elaborate (CA11012_0); +package CA11012_3 is new CA11012_0 (Int_Type => CA11012_2.My_Integer); + +with CA11012_0.CA11012_1; -- Complex additional operations +with CA11012_3; +package CA11012_3.CA11012_4 is new CA11012_3.CA11012_1; + + --==================================================================-- + +with CA11012_2; -- Package containing integer type +with CA11012_3.CA11012_4; -- Complex abstraction + additional operations +with Report; + +procedure CA11012 is + + package My_Complex_Pkg renames CA11012_3; + + package My_Complex_Operation renames CA11012_3.CA11012_4; + + use My_Complex_Pkg, -- All user-defined + My_Complex_Operation; -- operators directly + -- visible. + Complex_One, Complex_Two : Complex_Type; + +begin + + Report.Test ("CA11012", "Check that child instance can use its parent's " & + "declarations and operations, including a formal " & + "type of the parent"); + + Correct_Range_Test: + declare + My_Literal : CA11012_2.My_Integer := -3; + + begin + Complex_One := Complex (-4, 7); -- Operation from the generic + -- parent package. + + Complex_Two := My_Literal * Complex_One; -- Operation from the generic + -- child package. + + if Real_Part (Complex_Two) /= 12 -- Operation from the generic + or Imag_Part (Complex_Two) /= -21 -- child package. + then + Report.Failed ("Incorrect results from complex operation"); + end if; + + end Correct_Range_Test; + + --------------------------------------------------------------- + + Out_Of_Range_Test: + declare + My_Vector : CA11012_2.My_Integer; + + begin + Complex_One := Complex (70, 70); -- Operation from the generic + -- parent package. + My_Vector := Vector_Magnitude (Complex_One); + -- Operation from the generic child package. + + Report.Failed ("Exception not raised in child package"); + + exception + when Constraint_Error => + Report.Comment ("Exception is raised as expected"); + + when others => + Report.Failed ("Others exception is raised"); + + end Out_Of_Range_Test; + + Report.Result; + +end CA11012; diff --git a/gcc/testsuite/ada/acats/tests/ca/ca11013.a b/gcc/testsuite/ada/acats/tests/ca/ca11013.a new file mode 100644 index 000000000..c7f442788 --- /dev/null +++ b/gcc/testsuite/ada/acats/tests/ca/ca11013.a @@ -0,0 +1,201 @@ +-- CA11013.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 child function of a library level instantiation +-- of a generic can be the instantiation of a child function of +-- the generic. Check that the child instance can use its parent's +-- declarations and operations, including a formal subprogram of the +-- parent. +-- +-- TEST DESCRIPTION: +-- Declare a generic package which simulates a real complex +-- abstraction. Declare a generic child function of this package +-- which builds a random complex number. Declare a second +-- package which defines a random complex number generator. This +-- package provides actual parameters for the generic parent package. +-- +-- Instantiate the first generic package, then instantiate the child +-- generic function as a child unit of the first instance. In the main +-- program, check that the operations in both instances perform as +-- expected. +-- +-- +-- CHANGE HISTORY: +-- 06 Dec 94 SAIC ACVC 2.0 +-- 16 Nov 95 SAIC Update and repair for ACVC 2.0.1 +-- 19 Oct 96 SAIC ACVC 2.1: Added pragma Elaborate to context +-- clause of CA11013_3. +-- 27 Feb 97 CTA.PWB Added elaboration pragma at package CA11013_3 +--! + +generic -- Complex number abstraction. + type Real_Type is digits <>; + with function Random_Generator (Seed : Real_Type) return Real_Type; + +package CA11013_0 is + + -- Simulate a generic complex number support package. Complex numbers + -- are treated as coordinates in the Cartesian plane. + + type Complex_Type is + record + Real : Real_Type; + Imag : Real_Type; + end record; + + function Make (Real, Imag : Real_Type) -- Create a complex + return Complex_Type; -- number. + + procedure Components (Complex_No : in Complex_Type; + Real_Part, Imag_Part : out Real_Type); + +end CA11013_0; + + --==================================================================-- + +package body CA11013_0 is + + function Make (Real, Imag : Real_Type) return Complex_Type is + begin + return (Real, Imag); + end Make; + ------------------------------------------------------------- + procedure Components (Complex_No : in Complex_Type; + Real_Part, Imag_Part : out Real_Type) is + begin + Real_Part := Complex_No.Real; + Imag_Part := Complex_No.Imag; + end Components; + +end CA11013_0; + + --==================================================================-- + +-- Generic child of complex number package. This child adds a layer of +-- functionality to the parent generic. + +generic -- Random complex number operation. + +function CA11013_0.CA11013_1 (Seed : Real_Type) return Complex_Type; + + --==============================================-- + +function CA11013_0.CA11013_1 (Seed : Real_Type) return Complex_Type is + + Random_Real_Part : Real_Type := Random_Generator (Seed); + -- parent's formal subprogram + Random_Imag_Part : Real_Type + := Random_Generator (Random_Generator (Seed)); + -- parent's formal subprogram + Random_Complex_No : Complex_Type; + +begin -- CA11013_0.CA11013_1 + + Random_Complex_No := Make (Random_Real_Part, Random_Imag_Part); + -- operation from parent + return (Random_Complex_No); + +end CA11013_0.CA11013_1; + + --==================================================================-- + +package CA11013_2 is + + -- To be used as actual parameters for random number generator + -- in the parent package. + + type My_Float is digits 6 range -10.0 .. 100.0; + + function Random_Complex (Seed : My_float) return My_Float; + +end CA11013_2; + + --==================================================================-- + +package body CA11013_2 is + + -- Not a real random number generator. + function Random_Complex (Seed : My_float) return My_Float is + begin + return (Seed + 3.0); + end Random_Complex; + +end CA11013_2; + + --==================================================================-- + +-- Declare instances of the generic complex packages for real type. +-- The instance of the child must itself be declared as a child of the +-- instance of the parent. + +with CA11013_0; -- Complex number. +with CA11013_2; -- Random number generator. +pragma Elaborate (CA11013_0); +package CA11013_3 is new + CA11013_0 (Random_Generator => CA11013_2.Random_Complex, + Real_Type => CA11013_2.My_Float); + +with CA11013_0.CA11013_1; -- Random complex number operation. +with CA11013_3; +pragma Elaborate (CA11013_3); +function CA11013_3.CA11013_4 is new CA11013_3.CA11013_1; + + --==================================================================-- + +with Report; +with CA11013_2; -- Random number generator. +with CA11013_3.CA11013_4; -- Complex abstraction + Random complex + -- number operation. +procedure CA11013 is + + package My_Complex_Pkg renames CA11013_3; + use type CA11013_2.My_Float; + + My_Complex : My_Complex_Pkg.Complex_Type; + My_Literal : CA11013_2.My_Float := 3.0; + My_Real_Part, My_Imag_Part : CA11013_2.My_Float; + +begin + + Report.Test ("CA11013", "Check that child instance can use its parent's " & + "declarations and operations, including a formal " & + "subprogram of the parent"); + + My_Complex := CA11013_3.CA11013_4 (My_Literal); + -- Operation from the generic child function. + + My_Complex_Pkg.Components (My_Complex, My_Real_Part, My_Imag_Part); + -- Operation from the generic parent package. + + if My_Real_Part /= 6.0 -- Operation from the generic + or My_Imag_Part /= 9.0 -- parent package. + then + Report.Failed ("Incorrect results from complex operation"); + end if; + + Report.Result; + +end CA11013; diff --git a/gcc/testsuite/ada/acats/tests/ca/ca11014.a b/gcc/testsuite/ada/acats/tests/ca/ca11014.a new file mode 100644 index 000000000..7847a5067 --- /dev/null +++ b/gcc/testsuite/ada/acats/tests/ca/ca11014.a @@ -0,0 +1,302 @@ +-- CA11014.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 instantiation of a child package of a generic package +-- can use its parent's declarations and operations, including a formal +-- package of the parent. +-- +-- TEST DESCRIPTION: +-- Declare a list abstraction in a generic package which manages lists of +-- elements of any discrete type. Declare a generic package which +-- operates on lists of elements of integer types. Declare a generic +-- child of this package which defines additional list operations. +-- Use the formal discrete type as the generic formal actual part for the +-- parent formal package. +-- +-- Declare an instance of parent, then declare an instance of the child +-- which is itself a child the parent's instance. In the main program, +-- check that the operations in both instances perform as expected. +-- +-- +-- CHANGE HISTORY: +-- 06 Dec 94 SAIC ACVC 2.0 +-- 15 Nov 95 SAIC Update and repair for ACVC 2.0.1 +-- 07 Sep 96 SAIC Change formal param E to be out only. +-- 19 Oct 96 SAIC ACVC 2.1: Added pragma Elaborate to context +-- clauses of CA11014_0, CA11014_1, and CA11014_5. +-- 27 Feb 97 PWB.CTA Added elaboration pragma at package CA11014_4 +--! + +-- Actual package for the parent's formal. +generic + + type Element_Type is (<>); -- List elems may be of any discrete types. + +package CA11014_0 is + + type Node_Type; + type Node_Pointer is access Node_Type; + + type Node_Type is record + Item : Element_Type; + Next : Node_Pointer := null; + end record; + + type List_Type is record + First : Node_Pointer := null; + Current : Node_Pointer := null; + Last : Node_Pointer := null; + end record; + + -- 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); + +end CA11014_0; + + --==================================================================-- + +package body CA11014_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 CA11014_0; + + --==================================================================-- + +with CA11014_0; -- Generic list abstraction. +pragma Elaborate (CA11014_0); +generic + + -- Import the list abstraction defined in CA11014_0. + with package List_Mgr is new CA11014_0 (<>); + +package CA11014_1 is + + -- Write to current element and advance "current" pointer. + procedure Write_Element (L : in out List_Mgr.List_Type; + E : in List_Mgr.Element_Type); + + -- Read from current element and advance "current" pointer. + procedure Read_Element (L : in out List_Mgr.List_Type; + E : out List_Mgr.Element_Type); + + -- Add element to end of list. + procedure Add_Element (L : in out List_Mgr.List_Type; + E : in List_Mgr.Element_Type); + +end CA11014_1; + + --==================================================================-- + +package body CA11014_1 is + + procedure Write_Element (L : in out List_Mgr.List_Type; + E : in List_Mgr.Element_Type) is + begin + L.Current.Item := E; -- Write to current element. + L.Current := L.Current.Next; -- Advance "current" pointer. + end Write_Element; + ------------------------------------------------------- + procedure Read_Element (L : in out List_Mgr.List_Type; + E : out List_Mgr.Element_Type) is + begin + E := L.Current.Item; -- Retrieve current element. + L.Current := L.Current.Next; -- Advance "current" pointer. + end Read_Element; + ------------------------------------------------------- + procedure Add_Element (L : in out List_Mgr.List_Type; + E : in List_Mgr.Element_Type) is + New_Node : List_Mgr.Node_Pointer := new List_Mgr.Node_Type'(E, null); + use type List_Mgr.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 CA11014_1; + + --==================================================================-- + +-- Generic child of list operation. This child adds a layer of +-- functionality to the parent generic. + +generic + +package CA11014_1.CA11014_2 is + + procedure Write_First_To_List (L : in out List_Mgr.List_Type); + + -- ... Various other operations used by the application. + +end CA11014_1.CA11014_2; + + --==================================================================-- + +package body CA11014_1.CA11014_2 is + + procedure Write_First_To_List (L : in out List_Mgr.List_Type) is + begin + List_Mgr.Reset (L); -- Parent's formal package. + + while not List_Mgr.End_Of_List (L) loop -- Parent's formal package. + Write_Element (L, List_Mgr.Element_Type'First); + -- Parent's operation, + end loop; -- parent's formal. + + end Write_First_To_List; + +end CA11014_1.CA11014_2; + + --==================================================================-- + +package CA11014_3 is + + type Points is range 0 .. 100; + + -- ... Various other types used by the application. + +end CA11014_3; + + +-- No body for CA11014_3; + + --==================================================================-- + +-- Declare instances of the generic list packages for the discrete type. +-- The instance of the child must itself be declared as a child of the +-- instance of the parent. + +with CA11014_0; -- Generic list abstraction. +with CA11014_3; -- Package containing discrete type declaration. +pragma Elaborate (CA11014_0); +package CA11014_4 is new CA11014_0 (CA11014_3.Points); -- Points list. + +with CA11014_4; -- Points list. +with CA11014_1; -- Generic list operation. +pragma Elaborate (CA11014_1); +package CA11014_5 is new CA11014_1 (CA11014_4); -- Scores list. + +with CA11014_1.CA11014_2; -- Additional generic list operation, +with CA11014_5; +pragma Elaborate (CA11014_5); +package CA11014_5.CA11014_6 is new CA11014_5.CA11014_2; + -- Points list operation. + + --==================================================================-- + +with CA11014_1.CA11014_2; -- Additional generic list operation, + -- implicitly with list operation. +with CA11014_3; -- Package containing discrete type declaration. +with CA11014_4; -- Points list. +with CA11014_5.CA11014_6; -- Points list operation. +with Report; + +procedure CA11014 is + + package Lists_Of_Scores renames CA11014_4; + package Score_Ops renames CA11014_5; + package Point_Ops renames CA11014_5.CA11014_6; + + Scores : Lists_Of_Scores.List_Type; -- List of points. + + type TC_Score_Array is array (1 .. 3) of CA11014_3.Points; + + TC_Initial_Values : constant TC_Score_Array := (10, 21, 49); + TC_Final_Values : constant TC_Score_Array := (0, 0, 0); + + TC_Initial_Values_Are_Correct : boolean := false; + TC_Final_Values_Are_Correct : boolean := false; + + -------------------------------------------------- + + -- Initial list contains 3 scores with the values 10, 21, and 49. + procedure TC_Initialize_List (L : in out Lists_of_Scores.List_Type) is + begin + for I in TC_Score_Array'range loop + Score_Ops.Add_Element (L, TC_Initial_Values(I)); + -- Operation from generic parent. + end loop; + end TC_Initialize_List; + + -------------------------------------------------- + + -- Verify that all scores have been set to zero. + 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 + Lists_of_Scores.Reset (L); -- Operation from parent's formal. + for I in TC_Score_Array'range loop + Score_Ops.Read_Element (L, Actual(I)); + -- Operation from generic parent. + end loop; + OK := (Actual = Expected); + end TC_Verify_List; + + -------------------------------------------------- + +begin -- CA11014 + + Report.Test ("CA11014", "Check that an instantiation of a child package " & + "of a generic package can use its parent's " & + "declarations and operations, including a " & + "formal package of the parent"); + + TC_Initialize_List (Scores); + TC_Verify_List (Scores, TC_Initial_Values, TC_Initial_Values_Are_Correct); + + if not TC_Initial_Values_Are_Correct then + Report.Failed ("List contains incorrect initial values"); + end if; + + Point_Ops.Write_First_To_List (Scores); + -- Operation from generic child package. + + TC_Verify_List (Scores, TC_Final_Values, TC_Final_Values_Are_Correct); + + if not TC_Final_Values_Are_Correct then + Report.Failed ("List contains incorrect final values"); + end if; + + Report.Result; + +end CA11014; diff --git a/gcc/testsuite/ada/acats/tests/ca/ca11015.a b/gcc/testsuite/ada/acats/tests/ca/ca11015.a new file mode 100644 index 000000000..79b99ede8 --- /dev/null +++ b/gcc/testsuite/ada/acats/tests/ca/ca11015.a @@ -0,0 +1,312 @@ +-- CA11015.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 child of a non-generic package can use its +-- parent's declarations and operations. Check that the instantiation +-- of the generic child can correctly use the operations. +-- +-- TEST DESCRIPTION: +-- Declare a map abstraction in a package which manages basic physical +-- maps. Declare a generic child of this package which defines copies +-- of maps of any discrete type, i.e., population, density, or weather. +-- +-- In the main program, declare an instance of the child. Check that +-- the operations in the parent and instance of the child package +-- perform as expected. +-- +-- +-- CHANGE HISTORY: +-- 06 Dec 94 SAIC ACVC 2.0 +-- +--! + +-- Simulates map of physical features, i.e., desert, forest, water, +-- or plains. + +package CA11015_0 is + type Map_Type is private; + subtype Latitude is integer range 1 .. 9; + subtype Longitude is integer range 1 .. 7; + + type Physical_Features is (Desert, Forest, Water, Plains, Unexplored); + type Page_Type is range 0 .. 80; + + Terra_Incognita : exception; + + -- Use geographic database to initialize the basic map. + + procedure Initialize_Basic_Map (Map : in out Map_Type); + + function Get_Physical_Feature (Lat : Latitude; + Long : Longitude; + Map : Map_Type) return Physical_Features; + + function Next_Page return Page_Type; + +private + type Map_Type is array (Latitude, Longitude) of Physical_Features; + Basic_Map : Map_Type; + Page : Page_Type := 0; -- Location for each copy of Map. + +end CA11015_0; + + --==================================================================-- + +package body CA11015_0 is + + procedure Initialize_Basic_Map (Map : in out Map_Type) is + -- Not a real initialization. Real application can use geographic + -- database to create the basic map. + begin + for I in Latitude'first .. Latitude'last loop + for J in 1 .. 2 loop + Map (I, J) := Unexplored; + end loop; + for J in 3 .. 4 loop + Map (I, J) := Desert; + end loop; + for J in 5 .. 7 loop + Map (I, J) := Plains; + end loop; + end loop; + + end Initialize_Basic_Map; + --------------------------------------------------- + function Get_Physical_Feature (Lat : Latitude; + Long : Longitude; + Map : Map_Type) + return Physical_Features is + begin + return (Map (Lat, Long)); + end Get_Physical_Feature; + --------------------------------------------------- + function Next_Page return Page_Type is + begin + Page := Page + 1; + return (Page); + end Next_Page; + + --------------------------------------------------- + begin -- CA11015_0 + -- Initialize a basic map. + Initialize_Basic_Map (Basic_Map); + +end CA11015_0; + + --==================================================================-- + +-- Generic child package of physical map. Instantiate this package to +-- create map copy with a new geographic feature, i.e., population, density, +-- or weather. + +generic + + type Generic_Feature is (<>); -- Any geographic feature, i.e., population, + -- density, or weather that can be + -- characterized by a scalar value. + +package CA11015_0.CA11015_1 is + + type Feature_Map is private; + + function Get_Feature_Val (Lat : Latitude; + Long : Longitude; + Map : Feature_Map) return Generic_Feature; + + procedure Set_Feature_Val (Lat : in Latitude; + Long : in Longitude; + Fea : in Generic_Feature; + Map : in out Feature_Map); + + function Check_Page (Map : Feature_Map; + Page_No : Page_Type) return boolean; + +private + type Feature_Type is array (Latitude, Longitude) of Generic_Feature; + + type Feature_Map is + record + Feature : Feature_Type; + Page : Page_Type := Next_Page; -- Operation from parent. + end record; + +end CA11015_0.CA11015_1; + + --==================================================================-- + +package body CA11015_0.CA11015_1 is + + function Get_Feature_Val (Lat : Latitude; + Long : Longitude; + Map : Feature_Map) return Generic_Feature is + begin + return (Map.Feature (Lat, Long)); + end Get_Feature_Val; + --------------------------------------------------- + procedure Set_Feature_Val (Lat : in Latitude; + Long : in Longitude; + Fea : in Generic_Feature; + Map : in out Feature_Map) is + begin + if Get_Physical_Feature (Lat, Long, Basic_Map) = Unexplored + -- Parent's operation, + -- Parent's private object. + then + raise Terra_Incognita; -- Exception from parent. + else + Map.Feature (Lat, Long) := Fea; + end if; + end Set_Feature_Val; + --------------------------------------------------- + function Check_Page (Map : Feature_Map; + Page_No : Page_Type) return boolean is + begin + return (Map.Page = Page_No); + end Check_Page; + +end CA11015_0.CA11015_1; + + --==================================================================-- + +with CA11015_0.CA11015_1; -- Generic map operation, + -- implicitly withs parent, basic map + -- application. +with Report; + +procedure CA11015 is + +begin + + Report.Test ("CA11015", "Check that an instantiation of a child package " & + "of a non-generic package can use its parent's " & + "declarations and operations"); + +-- An application creates a population map using an integer type. + + Population_Map_Subtest: + declare + type Population_Type is range 0 .. 10_000; + + -- Declare instance of the child generic map package for one + -- particular integer type. + + package Population is new CA11015_0.CA11015_1 (Population_Type); + + Population_Map_Latitude : CA11015_0.Latitude := 1; + -- parent's type + Population_Map_Longitude : CA11015_0.Longitude := 5; + -- parent's type + Pop_Map : Population.Feature_Map; + Pop : Population_Type := 1000; + + begin + Population.Set_Feature_Val (Population_Map_Latitude, + Population_Map_Longitude, + Pop, + Pop_Map); + + If not ( (Population.Get_Feature_Val (Population_Map_Latitude, + Population_Map_Longitude, Pop_Map) = Pop) or + (Population.Check_Page (Pop_Map, 1)) ) then + Report.Failed ("Population map contains incorrect values"); + end if; + + end Population_Map_Subtest; + +-- An application creates a weather map using an enumeration type. + + Weather_Map_Subtest: + declare + type Weather_Type is (Hot, Cold, Mild); + + -- Declare instance of the child generic map package for one + -- particular enumeration type. + + package Weather_Pkg is new CA11015_0.CA11015_1 (Weather_Type); + + Weather_Map_Latitude : CA11015_0.Latitude := 2; + -- parent's type + Weather_Map_Longitude : CA11015_0.Longitude := 6; + -- parent's type + Weather_Map : Weather_Pkg.Feature_Map; + Weather : Weather_Type := Mild; + + begin + Weather_Pkg.Set_Feature_Val (Weather_Map_Latitude, + Weather_Map_Longitude, + Weather, + Weather_Map); + + if ( (Weather_Pkg.Get_Feature_Val (Weather_Map_Latitude, + Weather_Map_Longitude, Weather_Map) /= Weather) or + not (Weather_Pkg.Check_Page (Weather_Map, 2)) ) + then + Report.Failed ("Weather map contains incorrect values"); + end if; + + end Weather_Map_Subtest; + +-- During processing, the application may erroneously attempts to create +-- a density map on an unexplored area. This would result in the raising +-- of an exception. + + Density_Map_Subtest: + declare + type Density_Type is (High, Medium, Low); + + -- Declare instance of the child generic map package for one + -- particular enumeration type. + + package Density_Pkg is new CA11015_0.CA11015_1 (Density_Type); + + Density_Map_Latitude : CA11015_0.Latitude := 7; + -- parent's type + Density_Map_Longitude : CA11015_0.Longitude := 2; + -- parent's type + Density : Density_Type := Low; + Density_Map : Density_Pkg.Feature_Map; + + begin + Density_Pkg.Set_Feature_Val (Density_Map_Latitude, + Density_Map_Longitude, + Density, + Density_Map); + + Report.Failed ("Exception not raised in child generic package"); + + exception + + when CA11015_0.Terra_Incognita => -- parent's exception, + null; -- raised in child. + + when others => + Report.Failed ("Others exception is raised"); + + end Density_Map_Subtest; + + Report.Result; + +end CA11015; diff --git a/gcc/testsuite/ada/acats/tests/ca/ca11016.a b/gcc/testsuite/ada/acats/tests/ca/ca11016.a new file mode 100644 index 000000000..d6d4089a9 --- /dev/null +++ b/gcc/testsuite/ada/acats/tests/ca/ca11016.a @@ -0,0 +1,321 @@ +-- CA11016.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 child of a non-generic package can be a private generic +-- package. Check that the private child instance can use its parent's +-- declarations and operations. Check that the body of a public child +-- package can instantiate its sibling private generic package. +-- +-- TEST DESCRIPTION: +-- Declare a map abstraction in a package which manages basic physical +-- map[s]. Declare a private generic child of this package which can be +-- instantiated for any display device which has display locations of +-- the physical map that can be characterized by any integer type, i.e., +-- the intensity of the display point. +-- +-- Declare a public child of the physical map which specifies the +-- display device. In the body of this child, declare an instance of +-- its generic sibling to display the geographic locations. +-- +-- In the main program, check that the operations in the parent, public +-- child and instance of the private child package perform as expected. +-- +-- +-- CHANGE HISTORY: +-- 06 Dec 94 SAIC ACVC 2.0 +-- 17 Apr 96 SAIC ACVC 2.1: Added pragma Elaborate. +-- +--! + +-- Simulates map of physical features, i.e., desert, forest, or water. + +package CA11016_0 is + type Map_Type is private; + subtype Latitude is integer range 1 .. 9; + subtype Longitude is integer range 1 .. 7; + + type Physical_Features is (Desert, Forest, Water); + + -- Use geographic database to initialize the basic map. + + procedure Initialize_Basic_Map (Map : in out Map_Type); + + function Get_Physical_Feature (Lat : Latitude; + Long : Longitude; + Map : Map_Type) return Physical_Features; + +private + type Map_Type is array (Latitude, Longitude) of Physical_Features; + Basic_Map : Map_Type; + +end CA11016_0; + + --==================================================================-- + +package body CA11016_0 is + + procedure Initialize_Basic_Map (Map : in out Map_Type) is + -- Not a real initialization. Real application can use geographic + -- database to create the basic map. + + begin + for I in Latitude'first .. Latitude'last loop + for J in 1 .. 2 loop + Map (I, J) := Desert; + end loop; + for J in 3 .. 4 loop + Map (I, J) := Forest; + end loop; + for J in 5 .. 7 loop + Map (I, J) := Water; + end loop; + end loop; + + end Initialize_Basic_Map; + -------------------------------------------------------- + function Get_Physical_Feature (Lat : Latitude; + Long : Longitude; + Map : Map_Type) + return Physical_Features is + begin + return (Map (Lat, Long)); + end Get_Physical_Feature; + -------------------------------------------------------- + + begin + -- Initialize a basic map. + Initialize_Basic_Map (Basic_Map); + +end CA11016_0; + + --==================================================================-- + +-- Private generic child package of physical map. This generic package may +-- be instantiated for any display device which has display locations +-- (latitude, longitude) that can be characterized by an integer value. +-- For example, the intensity of the display point might be so characterized. +-- It can be instantiated for any desired range of values (which would +-- correspond to the range accepted by the display device). + + +private + +generic + + type Display_Value is range <>; -- Any display feature that is + -- represented by an integer. + +package CA11016_0.CA11016_1 is + + function Get_Display_Value (Lat : Latitude; + Long : Longitude; + Map : Map_Type) return Display_Value; + +end CA11016_0.CA11016_1; + + + --==================================================================-- + + +package body CA11016_0.CA11016_1 is + + function Get_Display_Value (Lat : Latitude; + Long : Longitude; + Map : Map_Type) + return Display_Value is + begin + case Get_Physical_Feature (Lat, Long, Map) is + -- Parent's operation, + when Forest => return (Display_Value'first); + -- Parent's type. + when Desert => return (Display_Value'last); + -- Parent's type. + when others => return + ( (Display_Value'last - Display_Value'first) / 2 ); + -- NOTE: Results are truncated. + end case; + + end Get_Display_Value; + +end CA11016_0.CA11016_1; + + + --==================================================================-- + +-- Map display operation, public child of physical map. + +package CA11016_0.CA11016_2 is + + -- Super-duper Ultra Geographic Display Device (SDUGD) can display + -- geographic locations with light intensity values ranging from 1 to 7. + + type Display_Val is range 1 .. 7; + + type Device_Color is (Brown, Blue, Green); + + type IO_Packet is + record + Lat : Latitude; -- Parent's type. + Long : Longitude; -- Parent's type. + Color : Device_Color; + Intensity : Display_Val; + end record; + + procedure Data_For_SDUGD (Lat : in Latitude; + Long : in Longitude; + Output_Packet : in out IO_Packet); + +end CA11016_0.CA11016_2; + + --==================================================================-- + + +with CA11016_0.CA11016_1; -- Private generic sibling. +pragma Elaborate (CA11016_0.CA11016_1); + +package body CA11016_0.CA11016_2 is + + -- Declare instance of the private generic sibling for + -- an integer type that represents color intensity. + + package SDUGD is new CA11016_0.CA11016_1 (Display_Val); + + procedure Data_For_SDUGD (Lat : in Latitude; + Long : in Longitude; + Output_Packet : in out IO_Packet) is + + -- Simulates sending control information to a display device. + -- Control information consists of latitude, longitude, a + -- color, and an intensity. + + begin + case Get_Physical_Feature (Lat, Long, Basic_Map) is + -- Parent's operation. + when Water => Output_Packet.Color := Blue; + Output_Packet.Intensity := SDUGD.Get_Display_Value + (Lat, Long, Basic_Map); + -- Sibling's operation. + when Forest => Output_Packet.Color := Green; + Output_Packet.Intensity := SDUGD.Get_Display_Value + (Lat, Long, Basic_Map); + -- Sibling's operation. + when others => Output_Packet.Color := Brown; + Output_Packet.Intensity := SDUGD.Get_Display_Value + (Lat, Long, Basic_Map); + -- Sibling's operation. + end case; + + end Data_For_SDUGD; + +end CA11016_0.CA11016_2; + + --==================================================================-- + +with CA11016_0.CA11016_2; -- Map display device operation, + -- implicitly withs parent, physical map + -- application. + +use CA11016_0.CA11016_2; -- Allows direct visibility to the simple + -- name of CA11016_0.CA11016_2. + +with Report; + +procedure CA11016 is + + TC_Packet : IO_Packet; + +begin + + Report.Test ("CA11016", "Check that body of a public child package can " & + "use its sibling private generic package " & + "declarations and operations"); + +-- Simulate control information at coordinates 3 and 7 of the +-- basic map for the SDUGD. + + Water_Display_Subtest: + begin + TC_Packet.Lat := 3; + TC_Packet.Long := 7; + + -- Build color and light intensity of the basic map at + -- latitude 3 and longitude 7. + + Data_For_SDUGD (TC_Packet.Lat, TC_Packet.Long, TC_Packet); + + if ( (TC_Packet.Color /= Blue) or + (TC_Packet.Intensity /= 3) ) then + Report.Failed ("Map display device contains " & + "incorrect values for water subtest"); + end if; + + end Water_Display_Subtest; + +-- Simulate control information at coordinates 2 and 1 of the +-- basic map for the SDUGD. + + Desert_Display_Subtest: + begin + TC_Packet.Lat := 9; + TC_Packet.Long := 2; + + -- Build color and light intensity of the basic map at + -- latitude 9 and longitude 2. + + Data_For_SDUGD (TC_Packet.Lat, TC_Packet.Long, TC_Packet); + + if ( (TC_Packet.Color /= Brown) or + (TC_Packet.Intensity /= 7) ) then + Report.Failed ("Map display device contains " & + "incorrect values for desert subtest"); + end if; + + end Desert_Display_Subtest; + +-- Simulate control information at coordinates 8 and 4 of the +-- basic map for the SDUGD. + + Forest_Display_Subtest: + begin + TC_Packet.Lat := 8; + TC_Packet.Long := 4; + + -- Build color and light intensity of the basic map at + -- latitude 8 and longitude 4. + + Data_For_SDUGD (TC_Packet.Lat, TC_Packet.Long, TC_Packet); + + if ( (TC_Packet.Color /= Green) or + (TC_Packet.Intensity /= 1) ) then + Report.Failed ("Map display device contains " & + "incorrect values for forest subtest"); + end if; + + end Forest_Display_Subtest; + + Report.Result; + +end CA11016; diff --git a/gcc/testsuite/ada/acats/tests/ca/ca11017.a b/gcc/testsuite/ada/acats/tests/ca/ca11017.a new file mode 100644 index 000000000..cbcce701d --- /dev/null +++ b/gcc/testsuite/ada/acats/tests/ca/ca11017.a @@ -0,0 +1,246 @@ +-- CA11017.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 body of the parent package may depend on one of its own +-- public children. +-- +-- TEST DESCRIPTION: +-- A scenario is created that demonstrates the potential of adding a +-- public child during code maintenance without distubing a large +-- subsystem. After child is added to the subsystem, a maintainer +-- decides to take advantage of the new functionality and rewrites +-- the parent's body. +-- +-- Declare a string abstraction in a package which manipulates string +-- replacement. Define a parent package which provides operations for +-- a record type with discriminant. Declare a public child of this +-- package which adds functionality to the original subsystem. In the +-- parent body, call operations from the public child. +-- +-- In the main program, check that operations in the parent and public +-- child perform as expected. +-- +-- +-- CHANGE HISTORY: +-- 06 Dec 94 SAIC ACVC 2.0 +-- +--! + +-- Simulates application which manipulates strings. + +package CA11017_0 is + + type String_Rec (The_Size : positive) is private; + + type Substring is new string; + + -- ... Various other types used by the application. + + procedure Replace (In_The_String : in out String_Rec; + At_The_Position : in positive; + With_The_String : in String_Rec); + + -- ... Various other operations used by the application. + +private + -- Different size for each individual record. + + type String_Rec (The_Size : positive) is + record + The_Length : natural := 0; + The_Content : Substring (1 .. The_Size); + end record; + +end CA11017_0; + + --=================================================================-- + +-- Public child added during code maintenance without disturbing a +-- large system. This public child would add functionality to the +-- original system. + +package CA11017_0.CA11017_1 is + + Position_Error : exception; + + function Equal_Length (Left : in String_Rec; + Right : in String_Rec) return boolean; + + function Same_Content (Left : in String_Rec; + Right : in String_Rec) return boolean; + + procedure Copy (From_The_Substring : in Substring; + To_The_String : in out String_Rec); + + -- ... Various other operations used by the application. + +end CA11017_0.CA11017_1; + + --=================================================================-- + +package body CA11017_0.CA11017_1 is + + function Equal_Length (Left : in String_Rec; + Right : in String_Rec) return boolean is + -- Quick comparison between the lengths of the input strings. + + begin + return (Left.The_Length = Right.The_Length); -- Parent's private + -- type. + end Equal_Length; + -------------------------------------------------------------------- + function Same_Content (Left : in String_Rec; + Right : in String_Rec) return boolean is + + begin + for I in 1 .. Left.The_Length loop + if Left.The_Content (I) = Right.The_Content (I) then + return true; + else + return false; + end if; + end loop; + + end Same_Content; + -------------------------------------------------------------------- + procedure Copy (From_The_Substring : in Substring; + To_The_String : in out String_Rec) is + begin + To_The_String.The_Content -- Parent's private type. + (1 .. From_The_Substring'length) := From_The_Substring; + + To_The_String.The_Length -- Parent's private type. + := From_The_Substring'length; + end Copy; + +end CA11017_0.CA11017_1; + + --=================================================================-- + +-- After child is added to the subsystem, a maintainer decides +-- to take advantage of the new functionality and rewrites the +-- parent's body. + +with CA11017_0.CA11017_1; + +package body CA11017_0 is + + -- Calls functions from public child for a quick comparison of the + -- input strings. If their lengths are the same, do the replacement. + + procedure Replace (In_The_String : in out String_Rec; + At_The_Position : in positive; + With_The_String : in String_Rec) is + End_Position : natural := At_The_Position + + With_The_String.The_Length - 1; + + begin + if not CA11017_0.CA11017_1.Equal_Length -- Public child's operation. + (With_The_String, In_The_String) then + raise CA11017_0.CA11017_1.Position_Error; + -- Public child's exception. + else + In_The_String.The_Content (At_The_Position .. End_Position) := + With_The_String.The_Content (1 .. With_The_String.The_Length); + end if; + + end Replace; + +end CA11017_0; + + --=================================================================-- + +with Report; + +with CA11017_0.CA11017_1; -- Explicit with public child package, + -- implicit with parent package (CA11017_0). + +procedure CA11017 is + + package String_Pkg renames CA11017_0; + use String_Pkg; + +begin + + Report.Test ("CA11017", "Check that body of the parent package can " & + "depend on one of its own public children"); + +-- Both input strings have the same size. Replace the first string by the +-- second string. + + Replace_Subtest: + declare + The_First_String, The_Second_String : String_Rec (16); + -- Parent's private type. + The_Position : positive := 1; + begin + CA11017_1.Copy ("This is the time", + To_The_String => The_First_String); + + CA11017_1.Copy ("For all good men", The_Second_String); + + Replace (The_First_String, The_Position, The_Second_String); + + -- Compare results using function from public child since + -- the type is private. + + if not CA11017_1.Same_Content + (The_First_String, The_Second_String) then + Report.Failed ("Incorrect results"); + end if; + + end Replace_Subtest; + +-- During processing, the application may erroneously attempt to replace +-- strings of different size. This would result in the raising of an +-- exception. + + Exception_Subtest: + declare + The_First_String : String_Rec (17); + -- Parent's private type. + The_Second_String : String_Rec (13); + -- Parent's private type. + The_Position : positive := 2; + begin + CA11017_1.Copy (" ACVC Version 2.0", The_First_String); + + CA11017_1.Copy (From_The_Substring => "ACVC 9X Basic", + To_The_String => The_Second_String); + + Replace (The_First_String, The_Position, The_Second_String); + + Report.Failed ("Exception was not raised"); + + exception + when CA11017_1.Position_Error => + Report.Comment ("Exception is raised as expected"); + + end Exception_Subtest; + + Report.Result; + +end CA11017; diff --git a/gcc/testsuite/ada/acats/tests/ca/ca11018.a b/gcc/testsuite/ada/acats/tests/ca/ca11018.a new file mode 100644 index 000000000..a01ebfc32 --- /dev/null +++ b/gcc/testsuite/ada/acats/tests/ca/ca11018.a @@ -0,0 +1,366 @@ +-- CA11018.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 body of the parent package may depend on one of its own +-- public generic children. +-- +-- TEST DESCRIPTION: +-- A scenario is created that demonstrates the potential of adding a +-- public generic child during code maintenance without distubing a large +-- subsystem. After child is added to the subsystem, a maintainer +-- decides to take advantage of the new functionality and rewrites +-- the parent's body. +-- +-- Declare a message application in a package which highlights some +-- key words. Declare a public generic child of this package which adds +-- functionality to the original subsystem. In the parent body, +-- instantiate the child. +-- +-- In the main program, check that the operations in the parent, +-- and instances of the public child package perform as expected. +-- +-- +-- CHANGE HISTORY: +-- 06 Dec 94 SAIC ACVC 2.0 +-- 14 Dec 94 SAIC Modified Copy_Particularly_Designated_Pkg inst. +-- 17 Nov 95 SAIC Update and repair for ACVC 2.0.1 +-- +--! + +-- Simulates application which displays messages. + +package CA11018_0 is + + type Designated_Num is new Integer range 0 .. 100; + + type Particularly_Designated_Num is new Integer range 0 .. 100; + + type Message is new String; + + type Message_Rec is tagged private; + + type Designated_Msg is new Message_Rec with private; + + type Particularly_Designated_Msg is new Message_Rec with private; + + -- Analyzes message for presence of word in the secret message. If found, + -- word is highlighted. + + procedure Highlight_Designated (The_Word : in Message; + In_The_Message : in out Designated_Msg); + + + -- Analyzes message for presence of word in the secret message. If found, + -- word is highlighted and do other actions. + + procedure Highlight_Particularly_Designated + (The_Word : in Message; + In_The_Message : in out Particularly_Designated_Msg); + + + -- Begin test code declarations: ----------------------- + + TC_Designated_Not_Zero : Boolean := false; + + TC_Particularly_Designated_Not_Zero : Boolean := false; + + -- The following two functions are used to check for function + -- calls from the public generic child. + + function TC_Designated_Success return Boolean; + + function TC_Particularly_Designated_Success return Boolean; + + -- End test code declarations. ------------------------- + +private + type Message_Rec is tagged + record + The_Length : natural := 0; + The_Content : Message (1 .. 60); + end record; + + type Designated_Msg is new Message_Rec with null record; + -- ... More components in real application. + + type Particularly_Designated_Msg is new Message_Rec with null record; + -- ... More components in real application. + +end CA11018_0; + + --=================================================================-- + + +-- Public generic child package of message display application. Imagine that +-- messages of one security level are associated with a type derived from +-- integer. For overall system security, messages of a different security +-- level are associated with a different type derived from integer. By +-- instantiating this package for each security level, the results of Count +-- applied to one kind of message cannot inadvertently be compared with the +-- results applied to a different kind. + +generic + type Msg_Type is new Message_Rec with private; + -- Derived from parent's type. + type Count is range <>; + +package CA11018_0.CA11018_1 is + + TC_Function_Called : Boolean := false; + + function Find_Word (Wrd : in Message; + Msg : in Msg_Type) return Count; + +end CA11018_0.CA11018_1; + + --=================================================================-- + +package body CA11018_0.CA11018_1 is + + function Find_Word (Wrd : in Message; + Msg : in Msg_Type) return Count is + + Num : Count := Count'first; + + -- Count how many time the word appears within the given message. + + begin + -- ... Error-checking code omitted for brevity. + + for I in 1 .. (Msg.The_Length - Wrd'length + 1) loop + -- Parent's private type + if Msg.The_Content (I .. I + Wrd'length - 1) = Wrd + -- Parent's private type + then + Num := Num + 1; + end if; + + end loop; + + TC_Function_Called := true; + + return (Num); + + end Find_Word; + +end CA11018_0.CA11018_1; + + --=================================================================-- + +with CA11018_0.CA11018_1; -- Public generic child. + +pragma Elaborate (CA11018_0.CA11018_1); +package body CA11018_0 is + + ---------------------------------------------------- + -- Parent's body depends on public generic child. -- + ---------------------------------------------------- + + -- Instantiate the public child for the secret message. + + package Designated_Pkg is new CA11018_0.CA11018_1 + (Msg_Type => Designated_Msg, Count => Designated_Num); + + -- Instantiate the public child for the top secret message. + + package Particularly_Designated_Pkg is new CA11018_0.CA11018_1 + (Particularly_Designated_Msg, Particularly_Designated_Num); + + -- End instantiations. ----------------------------- + + + function TC_Designated_Success return Boolean is + -- Check to see if the function in the public generic child is called. + + begin + return Designated_Pkg.TC_Function_Called; + end TC_Designated_Success; + -------------------------------------------------------------- + function TC_Particularly_Designated_Success return Boolean is + -- Check to see if the function in the public generic child is called. + + begin + return Particularly_Designated_Pkg.TC_Function_Called; + end TC_Particularly_Designated_Success; + -------------------------------------------------------------- + -- Calls functions from public child to search for a key word. + -- If the word appears more than once in each message, + -- highlight all of them. + + procedure Highlight_Designated (The_Word : in Message; + In_The_Message : in out Designated_Msg) is + + -- Not a real highlight procedure. Real application can use graphic + -- device to highlight all occurrences of words. + + begin + -------------------------------------------------------------- + -- Parent's body uses function from instantiation of public -- + -- generic child. -- + -------------------------------------------------------------- + + if Designated_Pkg.Find_Word -- Child's operation. + (The_Word, In_The_Message) > 0 then + + -- Highlight all occurrences in lavender. + + TC_Designated_Not_Zero := true; + end if; + + end Highlight_Designated; + -------------------------------------------------------------- + procedure Highlight_Particularly_Designated + (The_Word : in Message; + In_The_Message : in out Particularly_Designated_Msg) is + + -- Not a real highlight procedure. Real application can use graphic + -- device to highlight all occurrences of words. + + begin + -------------------------------------------------------------- + -- Parent's body uses function from instantiation of public -- + -- generic child. -- + -------------------------------------------------------------- + + if Particularly_Designated_Pkg.Find_Word -- Child's operation. + (The_Word, In_The_Message) > 0 then + + -- Highlight all occurrences in chartreuse. + -- Do other more secret stuff. + + TC_Particularly_Designated_Not_Zero := true; + end if; + + end Highlight_Particularly_Designated; + +end CA11018_0; + + --=================================================================-- + +-- Public generic child to copy words to the messages. + +generic + type Message_Type is new Message_Rec with private; + -- Derived from parent's type. + +package CA11018_0.CA11018_2 is + + procedure Copy (From_The_Word : in Message; + To_The_Message : in out Message_Type); + +end CA11018_0.CA11018_2; + + --=================================================================-- + +package body CA11018_0.CA11018_2 is + + procedure Copy (From_The_Word : in Message; + To_The_Message : in out Message_Type) is + + -- Copy words to the appropriate messages. + + begin + To_The_Message.The_Content -- Parent's private type. + (1 .. From_The_Word'length) := From_The_Word; + + To_The_Message.The_Length -- Parent's private type. + := From_The_Word'length; + end Copy; + +end CA11018_0.CA11018_2; + + --=================================================================-- + +with Report; + +with CA11018_0.CA11018_2; -- Public generic child package, copy words + -- to the message. + -- Implicit with parent package (CA11018_0). + +procedure CA11018 is + + package Message_Pkg renames CA11018_0; + +begin + + Report.Test ("CA11018", "Check that body of the parent package can " & + "depend on one of its own public generic children"); + +-- Highlight the word "Alert" from the secret message. + + Designated_Subtest: + declare + The_Message : Message_Pkg.Designated_Msg; -- Parent's private type. + + -- Instantiate the public child to copy words to the secret message. + + package Copy_Designated_Pkg is new CA11018_0.CA11018_2 + (Message_Pkg.Designated_Msg); + + begin + Copy_Designated_Pkg.Copy ("Alert Level 1 : Alert The Guard", + To_The_Message => The_Message); + + Message_Pkg.Highlight_Designated ("Alert", The_Message); + + if not Message_Pkg.TC_Designated_Not_Zero and + Message_Pkg.TC_Designated_Success then + Report.Failed ("Alert should have been highlighted"); + end if; + + end Designated_Subtest; + +-- Highlight the word "Push The Alarm" from the top secret message. + + Particularly_Designated_Subtest: + declare + The_Message : Message_Pkg.Particularly_Designated_Msg ; + -- Parent's private type. + + -- Instantiate the public child to copy words to the top secret + -- message. + + package Copy_Particularly_Designated_Pkg is new + CA11018_0.CA11018_2 (Message_Pkg.Particularly_Designated_Msg); + + begin + Copy_Particularly_Designated_Pkg.Copy + ("Alert Level 10 : Alert The Guard and Push The Alarm", + The_Message); + + Message_Pkg.Highlight_Particularly_Designated + ("Push The Alarm", The_Message); + + if not Message_Pkg.TC_Particularly_Designated_Not_Zero and + Message_Pkg.TC_Particularly_Designated_Success then + Report.Failed ("Key words should have been highlighted"); + end if; + + end Particularly_Designated_Subtest; + + Report.Result; + +end CA11018; diff --git a/gcc/testsuite/ada/acats/tests/ca/ca11019.a b/gcc/testsuite/ada/acats/tests/ca/ca11019.a new file mode 100644 index 000000000..92b3ba535 --- /dev/null +++ b/gcc/testsuite/ada/acats/tests/ca/ca11019.a @@ -0,0 +1,306 @@ +-- CA11019.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 body of the parent package may depend on one of its own +-- private generic children. +-- +-- TEST DESCRIPTION: +-- A scenario is created that demonstrates the potential of adding a +-- generic private child during code maintenance without distubing a +-- large subsystem. After child is added to the subsystem, a maintainer +-- decides to take advantage of the new functionality and rewrites +-- the parent's body. +-- +-- Declare a data collection abstraction in a package. Declare a private +-- generic child of this package which provides parameterized code that +-- have been written once and will be used three times to implement the +-- services of the parent package. In the parent body, instantiate the +-- private child. +-- +-- In the main program, check that the operations in the parent, +-- and instance of the private child package perform as expected. +-- +-- +-- CHANGE HISTORY: +-- 06 Dec 94 SAIC ACVC 2.0 +-- 17 Nov 95 SAIC Update and repair for ACVC 2.0.1 +-- +--! + +package CA11019_0 is + -- parent + + type Data_Record is tagged private; + type Data_Collection is private; + --- + --- + subtype Data_1 is integer range 0 .. 100; + procedure Add_1 (Data : Data_1; To : in out Data_Collection); + function Statistical_Op_1 (Data : Data_Collection) return Data_1; + --- + subtype Data_2 is integer range -100 .. 1000; + procedure Add_2 (Data : Data_2; To : in out Data_Collection); + function Statistical_Op_2 (Data : Data_Collection) return Data_2; + --- + subtype Data_3 is integer range -10_000 .. 10_000; + procedure Add_3 (Data : Data_3; To : in out Data_Collection); + function Statistical_Op_3 (Data : Data_Collection) return Data_3; + --- + +private + + type Data_Ptr is access Data_Record'class; + subtype Sequence_Number is positive range 1 .. 512; + + type Data_Record is tagged + record + Next : Data_Ptr := null; + Seq : Sequence_Number; + end record; + --- + type Data_Collection is + record + First : Data_Ptr := null; + Last : Data_Ptr := null; + end record; + +end CA11019_0; + -- parent + + --=================================================================-- + +-- This generic package provides parameterized code that has been +-- written once and will be used three times to implement the services +-- of the parent package. + +private +generic + type Data_Type is range <>; + +package CA11019_0.CA11019_1 is + -- parent.child + + type Data_Elem is new Data_Record with + record + Value : Data_Type; + end record; + + Next_Avail_Seq_No : Sequence_Number := 1; + + procedure Sequence (Ptr : Data_Ptr); + -- the child must be private for this procedure to know details of + -- the implementation of data collections + + procedure Add (Datum : Data_Type; To : in out Data_Collection); + + function Op (Data : Data_Collection) return Data_Type; + -- op models a complicated operation that whose code can be + -- used for various data types + + +end CA11019_0.CA11019_1; + -- parent.child + + --=================================================================-- + + +package body CA11019_0.CA11019_1 is + -- parent.child + + procedure Sequence (Ptr : Data_Ptr) is + begin + Ptr.Seq := Next_Avail_Seq_No; + Next_Avail_Seq_No := Next_Avail_Seq_No + 1; + end Sequence; + + --------------------------------------------------------- + + procedure Add (Datum : Data_Type; To : in out Data_Collection) is + Ptr : Data_Ptr; + begin + if To.First = null then + -- assign new record with data value to + -- to.next <- null; + To.First := new Data_Elem'(Next => null, + Value => Datum, + Seq => 1); + Sequence (To.First); + To.Last := To.First; + else + -- chase to end of list + Ptr := To.First; + while Ptr.Next /= null loop + Ptr := Ptr.Next; + end loop; + -- and add element there + Ptr.Next := new Data_Elem'(Next => null, + Value => Datum, + Seq => 1); + Sequence (Ptr.Next); + To.Last := Ptr.Next; + end if; + + end Add; + + --------------------------------------------------------- + + function Op (Data : Data_Collection) return Data_Type is + -- for simplicity, just return the maximum of the data set + Max : Data_Type := Data_Elem( Data.First.all ).Value; + -- assuming non-empty collection + Ptr : Data_Ptr := Data.First; + + begin + -- no error checking + while Ptr.Next /= null loop + if Data_Elem( Ptr.Next.all ).Value > Max then + Max := Data_Elem( Ptr.Next.all ).Value; + end if; + Ptr := Ptr.Next; + end loop; + return Max; + end Op; + +end CA11019_0.CA11019_1; + -- parent.child + + --=================================================================-- + +-- parent body depends on private generic child +with CA11019_0.CA11019_1; -- Private generic child. + +pragma Elaborate (CA11019_0.CA11019_1); +package body CA11019_0 is + + -- instantiate the generic child with data types needed by the + -- package interface services + package Data_1_Ops is new CA11019_1 + (Data_Type => Data_1); + + package Data_2_Ops is new CA11019_1 + (Data_Type => Data_2); + + package Data_3_Ops is new CA11019_1 + (Data_Type => Data_3); + + --------------------------------------------------------- + + procedure Add_1 (Data : Data_1; To : in out Data_Collection) is + begin + -- maybe do other stuff here + Data_1_Ops.Add (Data, To); + -- and here + end; + + --------------------------------------------------------- + + function Statistical_Op_1 (Data : Data_Collection) return Data_1 is + begin + -- maybe use generic operation(s) in some complicated ways + -- (but simplified out, for the sake of testing) + return Data_1_Ops.Op (Data); + end; + + --------------------------------------------------------- + + procedure Add_2 (Data : Data_2; To : in out Data_Collection) is + begin + Data_2_Ops.Add (Data, To); + end; + + --------------------------------------------------------- + + function Statistical_Op_2 (Data : Data_Collection) return Data_2 is + begin + return Data_2_Ops.Op (Data); + end; + + --------------------------------------------------------- + + procedure Add_3 (Data : Data_3; To : in out Data_Collection) is + begin + Data_3_Ops.Add (Data, To); + end; + + --------------------------------------------------------- + + function Statistical_Op_3 (Data : Data_Collection) return Data_3 is + begin + return Data_3_Ops.Op (Data); + end; + +end CA11019_0; + + + --=================================================-- + +with CA11019_0, + -- Main, + -- Main.Child is private + Report; + +procedure CA11019 is + + package Main renames CA11019_0; + + Col_1, + Col_2, + Col_3 : Main.Data_Collection; + +begin + + Report.Test ("CA11019", "Check that body of a (non-generic) package " & + "may depend on its private generic child"); + + -- build a data collection + + for I in 1 .. 10 loop + Main.Add_1 ( Main.Data_1(I), Col_1); + end loop; + + if Main.Statistical_Op_1 (Col_1) /= 10 then + Report.Failed ("Wrong data_1 value returned"); + end if; + + for I in reverse 10 .. 20 loop + Main.Add_2 ( Main.Data_2(I * 10), Col_2); + end loop; + + if Main.Statistical_Op_2 (Col_2) /= 200 then + Report.Failed ("Wrong data_2 value returned"); + end if; + + for I in 0 .. 10 loop + Main.Add_3 ( Main.Data_3(I + 5), Col_3); + end loop; + + if Main.Statistical_Op_3 (Col_3) /= 15 then + Report.Failed ("Wrong data_3 value returned"); + end if; + + Report.Result; + +end CA11019; diff --git a/gcc/testsuite/ada/acats/tests/ca/ca11020.a b/gcc/testsuite/ada/acats/tests/ca/ca11020.a new file mode 100644 index 000000000..4949ce9fe --- /dev/null +++ b/gcc/testsuite/ada/acats/tests/ca/ca11020.a @@ -0,0 +1,238 @@ +-- CA11020.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 body of the generic parent package can depend on one of +-- its own public generic children. +-- +-- TEST DESCRIPTION: +-- A scenario is created that demonstrates the potential of adding a +-- public generic child during code maintenance without distubing a large +-- subsystem. After child is added to the subsystem, a maintainer +-- decides to take advantage of the new functionality and rewrites +-- the parent's body. +-- +-- Declare a bag abstraction in a generic package. Declare a public +-- generic child of this package which adds a generic procedure to the +-- original subsystem. In the parent body, instantiate the public +-- child. Then instantiate the procedure as a child instance of the +-- public child instance. +-- +-- In the main program, declare an instance of parent. Check that the +-- operations in both parent and child packages perform as expected. +-- +-- +-- CHANGE HISTORY: +-- 06 Dec 94 SAIC ACVC 2.0 +-- +--! + +-- Simulates bag application. + +generic + type Element is private; + with function Image (E : Element) return String; + +package CA11020_0 is + + type Bag is limited private; + + procedure Add (E : in Element; To_The_Bag : in out Bag); + + function Bag_Image (B : Bag) return string; + +private + type Node_Type; + type Bag is access Node_Type; + + type Node_Type is + record + The_Element : Element; + + -- Other components in real application, i.e., + -- The_Count : positive; + + Next : Bag; + end record; + +end CA11020_0; + + --==================================================================-- + +-- More operations on Bag. + +generic + +-- Parameters go here. + +package CA11020_0.CA11020_1 is + + -- ... Other declarations. + + generic -- Generic iterator procedure. + with procedure Use_Element (E : in Element); + + procedure Iterate (B : in Bag); -- Called once per element in the bag. + + -- ... Various other operations. + +end CA11020_0.CA11020_1; + + --==================================================================-- + +package body CA11020_0.CA11020_1 is + + procedure Iterate (B : in Bag) is + + -- Traverse each element in the bag. + + Elem : Bag := B; + + begin + while Elem /= null loop + Use_Element (Elem.The_Element); + Elem := Elem.Next; + end loop; + + end Iterate; + +end CA11020_0.CA11020_1; + + --==================================================================-- + +with CA11020_0.CA11020_1; -- Public generic child package. + +package body CA11020_0 is + + ---------------------------------------------------- + -- Parent's body depends on public generic child. -- + ---------------------------------------------------- + + -- Instantiate the public child. + + package MS is new CA11020_1; + + function Bag_Image (B : Bag) return string is + + Buffer : String (1 .. 10_000); + Last : Integer := 0; + + ----------------------------------------------------- + + -- Will be called by the iterator. + + procedure Append_Image (E : in Element) is + Im : constant String := Image (E); + + begin -- Append_Image + if Last /= 0 then -- Insert a comma. + Last := Last + 1; + Buffer (Last) := ','; + end if; + + Buffer (Last + 1 .. Last + Im'Length) := Im; + Last := Last + Im'Length; + + end Append_Image; + + ----------------------------------------------------- + + -- Instantiate procedure Iterate as a child of instance MS. + + procedure Append_All is new MS.Iterate (Use_Element => Append_Image); + + begin -- Bag_Image + + Append_All (B); + + return Buffer (1 .. Last); + + end Bag_Image; + + ----------------------------------------------------- + + procedure Add (E : in Element; To_The_Bag : in out Bag) is + + -- Not a real bag addition. + + Index : Bag := To_The_Bag; + + begin + -- ... Error-checking code omitted for brevity. + + if Index = null then + To_The_Bag := new Node_Type' (The_Element => E, + Next => null); + else + -- Goto the end of the list. + + while Index.Next /= null loop + Index := Index.Next; + end loop; + + -- Add element to the end of the list. + + Index.Next := new Node_Type' (The_Element => E, + Next => null); + end if; + + end Add; + +end CA11020_0; + + --==================================================================-- + +with CA11020_0; -- Bag application. + +with Report; + +procedure CA11020 is + + -- Instantiate the bag application for integer type and attribute + -- Image. + + package Bag_Of_Integers is new CA11020_0 (Integer, Integer'Image); + + My_Bag : Bag_Of_Integers.Bag; + +begin + + Report.Test ("CA11020", "Check that body of the generic parent package " & + "can depend on one of its own public generic children"); + + -- Add 10 consecutive integers to the bag. + + for I in 1 .. 10 loop + Bag_Of_Integers.Add (I, My_Bag); + end loop; + + if Bag_Of_Integers.Bag_Image (My_Bag) + /= " 1, 2, 3, 4, 5, 6, 7, 8, 9, 10" then + Report.Failed ("Incorrect results"); + end if; + + Report.Result; + +end CA11020; diff --git a/gcc/testsuite/ada/acats/tests/ca/ca11021.a b/gcc/testsuite/ada/acats/tests/ca/ca11021.a new file mode 100644 index 000000000..f4da2f913 --- /dev/null +++ b/gcc/testsuite/ada/acats/tests/ca/ca11021.a @@ -0,0 +1,245 @@ +-- CA11021.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 body of the generic parent package can depend on one of +-- its own private generic children. +-- +-- TEST DESCRIPTION: +-- A scenario is created that demonstrates the potential of adding a +-- public generic child during code maintenance without distubing a large +-- subsystem. After child is added to the subsystem, a maintainer +-- decides to take advantage of the new functionality and rewrites +-- the parent's body. +-- +-- Declare a generic package which declares high level operations for a +-- complex number abstraction. Declare a private generic child package +-- of this package which defines low level complex operations. In the +-- parent body, instantiate the private child. Use the low level +-- operation to complete the high level operation. +-- +-- In the main program, instantiate the parent generic package. +-- Check that the operations in both packages perform as expected. +-- +-- +-- CHANGE HISTORY: +-- 06 Dec 94 SAIC ACVC 2.0 +-- +--! + +generic -- Complex number abstraction. + type Int_Type is range <>; + +package CA11021_0 is + + -- Simulate a generic complex number support package. Complex numbers + -- are treated as coordinates in the Cartesian plane. + + type Complex_Type is private; + + Zero : constant Complex_Type; -- Real number (0,0). + + function Real_Part (Complex_No : Complex_Type) + return Int_Type; + + function Imag_Part (Complex_No : Complex_Type) + return Int_Type; + + function Complex (Real, Imag : Int_Type) + return Complex_Type; + + -- High level operation for complex number. + function "*" (Factor : Int_Type; + C : Complex_Type) return Complex_Type; + + -- ... and other complicated ones. + +private + type Complex_Type is record + Real : Int_Type; + Imag : Int_Type; + end record; + + Zero : constant Complex_Type := (Real => 0, Imag => 0); + +end CA11021_0; + + --==================================================================-- + +-- Private generic child of Complex_Number. + +private + +generic + +-- No parameter. + +package CA11021_0.CA11021_1 is + + -- ... Other declarations. + + -- Low level operation on complex number. + function "+" (Left, Right : Complex_Type) + return Complex_Type; + + function "-" (Right : Complex_Type) + return Complex_Type; + + -- ... Various other operations in real application. + +end CA11021_0.CA11021_1; + + --==================================================================-- + +package body CA11021_0.CA11021_1 is + + function "+" (Left, Right : Complex_Type) + return Complex_Type is + + begin + return ( (Left.Real + Right.Real, Left.Imag + Right.Imag) ); + end "+"; + + -------------------------------------------------- + + function "-" (Right : Complex_Type) return Complex_Type is + begin + return (-Right.Real, -Right.Imag); + end "-"; + +end CA11021_0.CA11021_1; + + --==================================================================-- + +with CA11021_0.CA11021_1; -- Private generic child package. + +package body CA11021_0 is + + ----------------------------------------------------- + -- Parent's body depends on private generic child. -- + ----------------------------------------------------- + + -- Instantiate the private child. + + package Complex_Ops is new CA11021_1; + use Complex_Ops; -- All user-defined operators + -- directly visible. + + -------------------------------------------------- + + function "*" (Factor : Int_Type; + C : Complex_Type) return Complex_Type is + Result : Complex_Type := Zero; + + begin + for I in 1 .. abs (Factor) loop + Result := Result + C; -- Private generic child "+". + end loop; + + if Factor < 0 then + Result := - Result; -- Private generic child "-". + end if; + + return Result; + end "*"; + + -------------------------------------------------- + + function Real_Part (Complex_No : Complex_Type) return Int_Type is + begin + return (Complex_No.Real); + end Real_Part; + + -------------------------------------------------- + + function Imag_Part (Complex_No : Complex_Type) return Int_Type is + begin + return (Complex_No.Imag); + end Imag_Part; + + -------------------------------------------------- + + function Complex (Real, Imag : Int_Type) return Complex_Type is + begin + return (Real, Imag); + end Complex; + +end CA11021_0; + + --==================================================================-- + +with CA11021_0; -- Complex number abstraction. + +with Report; + +procedure CA11021 is + + type My_Integer is range -100 .. 100; + + -------------------------------------------------- + +-- Declare instance of the generic complex package for one particular +-- integer type. + + package My_Complex_Pkg is new + CA11021_0 (Int_Type => My_Integer); + + use My_Complex_Pkg; -- All user-defined operators + -- directly visible. + + -------------------------------------------------- + + Complex_One, Complex_Two : Complex_Type; + + My_Literal : My_Integer := -3; + +begin + + Report.Test ("CA11021", "Check that body of the generic parent package " & + "can depend on its private generic child"); + + Complex_One := Complex (11, 6); + + Complex_Two := 5 * Complex_One; + + if Real_Part (Complex_Two) /= 55 + and Imag_Part (Complex_Two) /= 30 + then + Report.Failed ("Incorrect results from complex operation"); + end if; + + Complex_One := Complex (-4, 7); + + Complex_Two := My_Literal * Complex_One; + + if Real_Part (Complex_Two) /= 12 + and Imag_Part (Complex_Two) /= -21 + then + Report.Failed ("Incorrect results from complex operation"); + end if; + + Report.Result; + +end CA11021; diff --git a/gcc/testsuite/ada/acats/tests/ca/ca11022.a b/gcc/testsuite/ada/acats/tests/ca/ca11022.a new file mode 100644 index 000000000..60cbc08ce --- /dev/null +++ b/gcc/testsuite/ada/acats/tests/ca/ca11022.a @@ -0,0 +1,242 @@ +-- CA11022.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 body of a child unit can instantiate its generic sibling. +-- +-- TEST DESCRIPTION: +-- Declare a package that provides some types for the graphic +-- application. Add a generic child package with a subprogram parameter +-- to provide algorithms that can be used by different terminal types +-- but that have to be customized to the specific terminal. Add child +-- packages to take advantage of the parent types and to provide a +-- customized operation for each of the different terminals. The +-- customized operation will be passed as a generic subprogram parameter +-- to the child package's sibling. +-- +-- The main program "with"s the child packages. Check that the +-- operations in child units perform as expected. +-- +-- +-- CHANGE HISTORY: +-- 06 Dec 94 SAIC ACVC 2.0 +-- +--! + +package CA11022_0 is -- Graphic Manager + + type Row is range 1 .. 66; + type Column is range 1 .. 80; + type Radius is range 1 .. 3; + type Length is range 5 .. 10; + + -- Testing artifice. + TC_Screen : array (Row, Column) of boolean := (others => (others => false)); + TC_Draw_Circle : boolean := false; + TC_Draw_Square : boolean := false; + + -- ... and other complicated ones. + +end CA11022_0; + +-- No bodies required for CA11022_0. + + --==================================================================-- + +-- Child package to provide general graphic functionalities. + +generic + + with procedure Put_Dot (X : in Column; + Y : in Row); + +package CA11022_0.CA11022_1 is + + procedure Draw_Square (At_Col : in Column; + At_Row : in Row; + Len : in Length); + + procedure Draw_Circle (At_Col : in Column; + At_Row : in Row; + Rad : in Radius); + + -- procedure Draw_Ellipse ... + -- and other drawings ... + +end CA11022_0.CA11022_1; + + --==================================================================-- + +package body CA11022_0.CA11022_1 is + + procedure Draw_Square (At_Col : in Column; + At_Row : in Row; + Len : in Length) is + begin + -- use square drawing algorithm + -- call + Put_Dot (At_Col + Column (Len), At_Row + Row(Len)); + -- as needed in the algorithm. + TC_Draw_Square := true; + end Draw_Square; + + ------------------------------------------------------- + procedure Draw_Circle (At_Col : in Column; + At_Row : in Row; + Rad : in Radius) is + begin + -- use circle drawing algorithm + -- call + for I in 1 .. Rad loop + Put_Dot (At_Col + Column(I), At_Row + Row(I)); + end loop; + -- as needed in the algorithm. + TC_Draw_Circle := true; + end Draw_Circle; + +end CA11022_0.CA11022_1; + + --==================================================================-- + +with CA11022_0.CA11022_1; -- Generic sibling. + +-- Child package to provide customized graphic functions for the +-- VT100. +package CA11022_0.CA11022_2 is -- VT100 Graphic. + + X : Column := 8; + Y : Row := 3; + R : Radius := 2; + L : Length := 6; + + procedure VT100_Graphic; + +end CA11022_0.CA11022_2; + + --==================================================================-- + +package body CA11022_0.CA11022_2 is + + procedure VT100_Graphic is + procedure VT100_Putdot (X : in Column; + Y : in Row) is + begin + -- Light a pixel at location (X, Y); + TC_Screen (Y, X) := true; + end VT100_Putdot; + + ------------------------------------ + + -- Declare instance of the generic sibling package to draw a circle, + -- a square, or an ellipse customized for the VT100. + package VT100_Graphic is new CA11022_0.CA11022_1 (VT100_Putdot); + + begin + VT100_Graphic.Draw_Circle (X, Y, R); + VT100_Graphic.Draw_Square (X, Y, L); + end VT100_Graphic; + +end CA11022_0.CA11022_2; + + --==================================================================-- + +with CA11022_0.CA11022_1; -- Generic sibling. + +-- Child package to provide customized graphic functions for the +-- IBM3270. +package CA11022_0.CA11022_3 is -- IBM3270 Graphic. + + X : Column := 39; + Y : Row := 11; + R : Radius := 3; + L : Length := 7; + + procedure IBM3270_Graphic; + +end CA11022_0.CA11022_3; + + --==================================================================-- + +package body CA11022_0.CA11022_3 is + + procedure IBM3270_Graphic is + procedure IBM3270_Putdot (X : in Column; + Y : in Row) is + begin + -- Light a pixel at location (X + 2, Y); + TC_Screen (Y, X + Column(2)) := true; + end IBM3270_Putdot; + + ------------------------------------ + + -- Declare instance of the generic sibling package to draw a circle, + -- a square, or an ellipse customized for the IBM3270. + package IBM3270_Graphic is new CA11022_0.CA11022_1 (IBM3270_Putdot); + + begin + IBM3270_Graphic.Draw_Circle (X, Y, R); + IBM3270_Graphic.Draw_Square (X, Y, L); + end IBM3270_Graphic; + +end CA11022_0.CA11022_3; + + --==================================================================-- + +with CA11022_0.CA11022_2; -- VT100 Graphic, implicitly with + -- CA11022_0, Graphic Manager. +with CA11022_0.CA11022_3; -- IBM3270 Graphic. +with Report; + +procedure CA11022 is + +begin + + Report.Test ("CA11022", "Check that body of a child unit can depend on " & + "its generic sibling"); + + -- Customized graphic functions for the VT100 terminal. + CA11022_0.CA11022_2.VT100_Graphic; + + if not CA11022_0.TC_Screen (4,9) and not CA11022_0.TC_Screen (5,10) + and not CA11022_0.TC_Screen (9,14) and not CA11022_0.TC_Draw_Circle + and not CA11022_0.TC_Draw_Square then + Report.Failed ("Wrong results for the VT100"); + end if; + + CA11022_0.TC_Draw_Circle := false; + CA11022_0.TC_Draw_Square := false; + + -- Customized graphic functions for the IBM3270 terminal. + CA11022_0.CA11022_3.IBM3270_Graphic; + + if not CA11022_0.TC_Screen (12,42) and not CA11022_0.TC_Screen (13,43) + and not CA11022_0.TC_Screen (14,44) and not CA11022_0.TC_Screen (46,18) + and not CA11022_0.TC_Draw_Circle and not CA11022_0.TC_Draw_Square then + Report.Failed ("Wrong results for the IBM3270"); + end if; + + Report.Result; + +end CA11022; diff --git a/gcc/testsuite/ada/acats/tests/ca/ca1102a0.ada b/gcc/testsuite/ada/acats/tests/ca/ca1102a0.ada new file mode 100644 index 000000000..23f766fb5 --- /dev/null +++ b/gcc/testsuite/ada/acats/tests/ca/ca1102a0.ada @@ -0,0 +1,31 @@ +-- CA1102A0.ADA + +-- Grant of Unlimited Rights +-- +-- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687, +-- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained +-- unlimited rights in the software and documentation contained herein. +-- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making +-- this public release, the Government intends to confer upon all +-- recipients unlimited rights equal to those held by the Government. +-- These rights include rights to use, duplicate, release or disclose the +-- released technical data and computer software in whole or in part, in +-- any manner and for any purpose whatsoever, and to have or permit others +-- to do so. +-- +-- DISCLAIMER +-- +-- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR +-- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED +-- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE +-- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE +-- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A +-- PARTICULAR PURPOSE OF SAID MATERIAL. +--* +-- WKB 6/12/81 + +PACKAGE CA1102A0 IS -- BODY IS IN CA1102A1. + + PROCEDURE P (INVOKED : IN OUT BOOLEAN); + +END CA1102A0; diff --git a/gcc/testsuite/ada/acats/tests/ca/ca1102a1.ada b/gcc/testsuite/ada/acats/tests/ca/ca1102a1.ada new file mode 100644 index 000000000..e201a5148 --- /dev/null +++ b/gcc/testsuite/ada/acats/tests/ca/ca1102a1.ada @@ -0,0 +1,36 @@ +-- CA1102A1.ADA + +-- Grant of Unlimited Rights +-- +-- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687, +-- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained +-- unlimited rights in the software and documentation contained herein. +-- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making +-- this public release, the Government intends to confer upon all +-- recipients unlimited rights equal to those held by the Government. +-- These rights include rights to use, duplicate, release or disclose the +-- released technical data and computer software in whole or in part, in +-- any manner and for any purpose whatsoever, and to have or permit others +-- to do so. +-- +-- DISCLAIMER +-- +-- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR +-- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED +-- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE +-- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE +-- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A +-- PARTICULAR PURPOSE OF SAID MATERIAL. +--* +-- WKB 6/12/81 + +PACKAGE BODY CA1102A0 IS + + PROCEDURE P (INVOKED : IN OUT BOOLEAN) IS + BEGIN + INVOKED := TRUE; + END P; + +BEGIN + NULL; +END CA1102A0; diff --git a/gcc/testsuite/ada/acats/tests/ca/ca1102a2.ada b/gcc/testsuite/ada/acats/tests/ca/ca1102a2.ada new file mode 100644 index 000000000..b4cffd124 --- /dev/null +++ b/gcc/testsuite/ada/acats/tests/ca/ca1102a2.ada @@ -0,0 +1,58 @@ +-- CA1102A2M.ADA + +-- Grant of Unlimited Rights +-- +-- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687, +-- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained +-- unlimited rights in the software and documentation contained herein. +-- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making +-- this public release, the Government intends to confer upon all +-- recipients unlimited rights equal to those held by the Government. +-- These rights include rights to use, duplicate, release or disclose the +-- released technical data and computer software in whole or in part, in +-- any manner and for any purpose whatsoever, and to have or permit others +-- to do so. +-- +-- DISCLAIMER +-- +-- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR +-- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED +-- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF 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 MORE THAN ONE WITH_CLAUSE CAN APPEAR IN +-- A CONTEXT_SPECIFICATION. +-- CHECK THAT USE_CLAUSES CAN MENTION NAMES MADE +-- VISIBLE BY PRECEDING WITH_CLAUSES IN THE SAME +-- CONTEXT_SPECIFICATION. +-- CHECK THAT CONSECUTIVE USE_CLAUSES ARE ALLOWED. + +-- SEPARATE FILES ARE: +-- CA1102A0 A LIBRARY PACKAGE DECLARATION. +-- CA1102A1 A LIBRARY PACKAGE BODY (CA1102A0). +-- CA1102A2M THE MAIN PROCEDURE. + +-- WKB 6/12/81 +-- BHS 7/19/84 + +WITH CA1102A0; +WITH REPORT; USE CA1102A0; USE REPORT; +PROCEDURE CA1102A2M IS + + + INVOKED : BOOLEAN := FALSE; + +BEGIN + TEST ("CA1102A", "MORE THAN ONE WITH_CLAUSE; ALSO, A " & + "USE_CLAUSE REFERING TO A PRECEDING WITH_CLAUSE " & + "IN THE SAME CONTEXT_SPECIFICATION"); + + P (INVOKED); + IF NOT INVOKED THEN + FAILED ("COMPILATION UNIT NOT MADE VISIBLE"); + END IF; + + RESULT; +END CA1102A2M; diff --git a/gcc/testsuite/ada/acats/tests/ca/ca1106a.ada b/gcc/testsuite/ada/acats/tests/ca/ca1106a.ada new file mode 100644 index 000000000..b3da9d102 --- /dev/null +++ b/gcc/testsuite/ada/acats/tests/ca/ca1106a.ada @@ -0,0 +1,112 @@ +-- CA1106A.ADA + +-- Grant of Unlimited Rights +-- +-- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687, +-- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained +-- unlimited rights in the software and documentation contained herein. +-- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making +-- this public release, the Government intends to confer upon all +-- recipients unlimited rights equal to those held by the Government. +-- These rights include rights to use, duplicate, release or disclose the +-- released technical data and computer software in whole or in part, in +-- any manner and for any purpose whatsoever, and to have or permit others +-- to do so. +-- +-- DISCLAIMER +-- +-- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR +-- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED +-- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF 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 WITH CLAUSE FOR A PACKAGE BODY (GENERIC OR +-- NONGENERIC) OR FOR A GENERIC SUBPROGRAM BODY CAN NAME THE +-- CORRESPONDING SPECIFICATION, AND A USE CLAUSE CAN ALSO BE +-- GIVEN. + +-- HISTORY: +-- JET 07/14/88 CREATED ORIGINAL TEST. +-- PWN 05/25/94 ADDED A PROCEDURE TO KEEP PACKAGE BODIES LEGAL. + +PACKAGE CA1106A_1 IS + I : INTEGER := 0; + PROCEDURE REQUIRE_BODY; +END CA1106A_1; + +GENERIC + TYPE TG IS RANGE <>; +PACKAGE CA1106A_2 IS + J : TG := 0; + PROCEDURE REQUIRE_BODY; +END CA1106A_2; + +GENERIC + TYPE TG IS RANGE <>; +FUNCTION CA1106A_3 RETURN TG; + +WITH REPORT; USE REPORT; +WITH CA1106A_1; USE CA1106A_1; +PRAGMA ELABORATE (REPORT); +PACKAGE BODY CA1106A_1 IS + PROCEDURE REQUIRE_BODY IS + BEGIN + NULL; + END; +BEGIN + I := IDENT_INT(1); +END CA1106A_1; + +WITH REPORT; USE REPORT; +WITH CA1106A_2; +PRAGMA ELABORATE (REPORT); +PACKAGE BODY CA1106A_2 IS + PROCEDURE REQUIRE_BODY IS + BEGIN + NULL; + END; +BEGIN + J := TG(IDENT_INT(2)); +END CA1106A_2; + +WITH REPORT; USE REPORT; +WITH CA1106A_3; +FUNCTION CA1106A_3 RETURN TG IS +BEGIN + RETURN TG(IDENT_INT(3)); +END CA1106A_3; + +WITH REPORT; USE REPORT; +WITH CA1106A_1, CA1106A_2, CA1106A_3; +USE CA1106A_1; +PROCEDURE CA1106A IS + + PACKAGE CA1106A_2X IS NEW CA1106A_2 (INTEGER); + FUNCTION CA1106A_3X IS NEW CA1106A_3 (INTEGER); + + USE CA1106A_2X; + +BEGIN + TEST ("CA1106A", "CHECK THAT A WITH CLAUSE FOR A PACKAGE BODY " & + "(GENERIC OR NONGENERIC) OR FOR A GENERIC " & + "SUBPROGRAM BODY CAN NAME THE CORRESPONDING " & + "SPECIFICATION, AND A USE CLAUSE CAN ALSO BE " & + "GIVEN"); + + IF I /= 1 THEN + FAILED ("INCORRECT VALUE FROM NONGENERIC PACKAGE"); + END IF; + + IF J /= 2 THEN + FAILED ("INCORRECT VALUE FROM GENERIC PACKAGE"); + END IF; + + IF CA1106A_3X /= 3 THEN + FAILED ("INCORRECT VALUE FROM GENERIC SUBPROGRAM"); + END IF; + + RESULT; +END CA1106A; diff --git a/gcc/testsuite/ada/acats/tests/ca/ca1108a.ada b/gcc/testsuite/ada/acats/tests/ca/ca1108a.ada new file mode 100644 index 000000000..7059d26c8 --- /dev/null +++ b/gcc/testsuite/ada/acats/tests/ca/ca1108a.ada @@ -0,0 +1,136 @@ +-- CA1108A.ADA + +-- Grant of Unlimited Rights +-- +-- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687, +-- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained +-- unlimited rights in the software and documentation contained herein. +-- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making +-- this public release, the Government intends to confer upon all +-- recipients unlimited rights equal to those held by the Government. +-- These rights include rights to use, duplicate, release or disclose the +-- released technical data and computer software in whole or in part, in +-- any manner and for any purpose whatsoever, and to have or permit others +-- to do so. +-- +-- DISCLAIMER +-- +-- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR +-- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED +-- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF 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 WITH_CLAUSE AND USE_CLAUSE GIVEN FOR A PACKAGE +-- SPECIFICATION APPLIES TO THE BODY AND SUBUNITS OF THE BODY. + +-- BHS 7/27/84 +-- JBG 5/1/85 + +PACKAGE OTHER_PKG IS + + I : INTEGER := 4; + FUNCTION F (X : INTEGER) RETURN INTEGER; + +END OTHER_PKG; + +PACKAGE BODY OTHER_PKG IS + + FUNCTION F (X : INTEGER) RETURN INTEGER IS + BEGIN + RETURN X + 1; + END F; + +END OTHER_PKG; + +WITH REPORT, OTHER_PKG; +USE REPORT, OTHER_PKG; +PRAGMA ELABORATE (OTHER_PKG); +PACKAGE CA1108A_PKG IS + + J : INTEGER := 2; + PROCEDURE PROC; + PROCEDURE CALL_SUBS (X, Y : IN OUT INTEGER); + +END CA1108A_PKG; + +PACKAGE BODY CA1108A_PKG IS + + PROCEDURE SUB (X, Y : IN OUT INTEGER) IS SEPARATE; + + PROCEDURE PROC IS + Y : INTEGER := 2; + BEGIN + Y := OTHER_PKG.I; + IF Y /= 4 THEN + FAILED ("OTHER_PKG VARIABLE NOT VISIBLE " & + "IN PACKAGE BODY PROCEDURE"); + END IF; + END PROC; + + PROCEDURE CALL_SUBS (X, Y : IN OUT INTEGER) IS + BEGIN + SUB (X, Y); + END CALL_SUBS; + +BEGIN + + J := F(J); -- J => J + 1. + IF J /= 3 THEN + FAILED ("OTHER_PKG FUNCTION NOT VISIBLE IN " & + "PACKAGE BODY"); + END IF; + +END CA1108A_PKG; + + +WITH REPORT, CA1108A_PKG; +USE REPORT, CA1108A_PKG; +PROCEDURE CA1108A IS + + VAR1, VAR2 : INTEGER; + +BEGIN + + TEST ("CA1108A", "WITH_ AND USE_CLAUSES GIVEN FOR A PACKAGE " & + "SPEC APPLY TO THE BODY AND ITS SUBUNITS"); + + PROC; + + VAR1 := 1; + VAR2 := 1; + CALL_SUBS (VAR1, VAR2); + IF VAR1 /= 4 THEN + FAILED ("OTHER_PKG VARIABLE NOT VISIBLE IN SUBUNIT"); + END IF; + + IF VAR2 /= 6 THEN + FAILED ("OTHER_PKG FUNCTION NOT VISIBLE IN SUBUNIT " & + "OF SUBUNIT"); + END IF; + + RESULT; + +END CA1108A; + + +SEPARATE (CA1108A_PKG) +PROCEDURE SUB (X, Y : IN OUT INTEGER) IS + PROCEDURE SUB2 (Z : IN OUT INTEGER) IS SEPARATE; +BEGIN + + X := I; + SUB2 (Y); + +END SUB; + + +SEPARATE (CA1108A_PKG.SUB) +PROCEDURE SUB2 (Z : IN OUT INTEGER) IS + I : INTEGER := 5; +BEGIN + + Z := OTHER_PKG.F(I); -- Z => I + 1. + +END SUB2; diff --git a/gcc/testsuite/ada/acats/tests/ca/ca1108b.ada b/gcc/testsuite/ada/acats/tests/ca/ca1108b.ada new file mode 100644 index 000000000..287772836 --- /dev/null +++ b/gcc/testsuite/ada/acats/tests/ca/ca1108b.ada @@ -0,0 +1,168 @@ +-- CA1108B.ADA + +-- Grant of Unlimited Rights +-- +-- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687, +-- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained +-- unlimited rights in the software and documentation contained herein. +-- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making +-- this public release, the Government intends to confer upon all +-- recipients unlimited rights equal to those held by the Government. +-- These rights include rights to use, duplicate, release or disclose the +-- released technical data and computer software in whole or in part, in +-- any manner and for any purpose whatsoever, and to have or permit others +-- to do so. +-- +-- DISCLAIMER +-- +-- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR +-- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED +-- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE +-- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE +-- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A +-- PARTICULAR PURPOSE OF SAID MATERIAL. +--* +-- CHECK THAT IF WITH_CLAUSES ARE GIVEN FOR BOTH A SPEC AND A BODY, AND +-- THE CLAUSES NAME DIFFERENT LIBRARY UNITS, THE UNITS NAMED IN ALL THE +-- CLAUSES ARE VISIBLE IN THE BODY AND IN SUBUNITS OF THE BODY. + +-- BHS 7/31/84 +-- JBG 5/1/85 + +PACKAGE FIRST_PKG IS + + FUNCTION F (X : INTEGER := 1) RETURN INTEGER; + +END FIRST_PKG; + +PACKAGE BODY FIRST_PKG IS + + FUNCTION F (X : INTEGER := 1) RETURN INTEGER IS + BEGIN + RETURN X; + END F; + +END FIRST_PKG; + +PACKAGE LATER_PKG IS + + FUNCTION F (Y : INTEGER := 2) RETURN INTEGER; + +END LATER_PKG; + +PACKAGE BODY LATER_PKG IS + + FUNCTION F (Y : INTEGER := 2) RETURN INTEGER IS + BEGIN + RETURN Y + 1; + END F; + +END LATER_PKG; + +WITH REPORT, FIRST_PKG; +USE REPORT; +PRAGMA ELABORATE (FIRST_PKG); +PACKAGE CA1108B_PKG IS + + I, J : INTEGER; + PROCEDURE PROC; + PROCEDURE CALL_SUBS (X, Y : IN OUT INTEGER); + +END CA1108B_PKG; + +WITH LATER_PKG; +PRAGMA ELABORATE (LATER_PKG); +PACKAGE BODY CA1108B_PKG IS + + PROCEDURE SUB (X, Y : IN OUT INTEGER) IS SEPARATE; + + PROCEDURE PROC IS + I, J : INTEGER; + BEGIN + I := FIRST_PKG.F; + IF I /= 1 THEN + FAILED ("FIRST_PKG FUNCTION NOT VISIBLE IN " & + "PACKAGE BODY PROCEDURE"); + END IF; + J := LATER_PKG.F; + IF J /= 3 THEN + FAILED ("LATER_PKG FUNCITON NOT VISIBLE IN " & + "PACKAGE BODY PROCEDURE"); + END IF; + END PROC; + + PROCEDURE CALL_SUBS (X, Y : IN OUT INTEGER) IS + BEGIN + SUB (X, Y); + END CALL_SUBS; + +BEGIN + + I := FIRST_PKG.F; + IF I /= 1 THEN + FAILED ("FIRST_PKG FUNCTION NOT VISIBLE IN PACKAGE BODY"); + END IF; + J := LATER_PKG.F; + IF J /= 3 THEN + FAILED ("LATER_PKG FUNCTION NOT VISIBLE IN PACKAGE BODY"); + END IF; + +END CA1108B_PKG; + +WITH REPORT, CA1108B_PKG; +USE REPORT, CA1108B_PKG; +PROCEDURE CA1108B IS + + VAR1, VAR2 : INTEGER; + +BEGIN + + TEST ("CA1108B", "IF DIFFERENT WITH_CLAUSES GIVEN FOR PACKAGE " & + "SPEC AND BODY, ALL NAMED UNITS ARE VISIBLE " & + "IN THE BODY AND ITS SUBUNITS"); + + PROC; + + VAR1 := 0; + VAR2 := 1; + CALL_SUBS (VAR1, VAR2); + IF VAR1 /= 1 THEN + FAILED ("FIRST_PKG FUNCTION NOT VISIBLE IN SUBUNIT"); + END IF; + + IF VAR2 /= 3 THEN + FAILED ("LATER_PKG FUNCTION NOT VISIBLE IN SUBUNIT"); + END IF; + + RESULT; + +END CA1108B; + + +SEPARATE (CA1108B_PKG) +PROCEDURE SUB (X, Y : IN OUT INTEGER) IS + PROCEDURE SUB2 (A, B : IN OUT INTEGER) IS SEPARATE; +BEGIN + + SUB2 (Y, X); + IF Y /= 1 THEN + FAILED ("FIRST_PKG FUNCTION NOT VISIBLE IN SUBUNIT " & + "OF SUBUNIT"); + END IF; + IF X /= 3 THEN + FAILED ("LATER_PKG FUNCTION NOT VISIBLE IN SUBUNIT " & + "OF SUBUNIT"); + END IF; + X := FIRST_PKG.F; + Y := LATER_PKG.F; + +END SUB; + +SEPARATE (CA1108B_PKG.SUB) +PROCEDURE SUB2 (A, B : IN OUT INTEGER) IS +BEGIN + + A := FIRST_PKG.F; + B := LATER_PKG.F; + +END SUB2; diff --git a/gcc/testsuite/ada/acats/tests/ca/ca11a01.a b/gcc/testsuite/ada/acats/tests/ca/ca11a01.a new file mode 100644 index 000000000..a84c6b84f --- /dev/null +++ b/gcc/testsuite/ada/acats/tests/ca/ca11a01.a @@ -0,0 +1,228 @@ +-- CA11A01.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 type extended in a public child inherits primitive +-- operations from its ancestor. +-- +-- TEST DESCRIPTION: +-- Declare a root tagged type in a package specification. Declare two +-- primitive subprograms for the type (foundation code). +-- +-- Add a public child to the above package. Extend the root type with +-- a record extension in the specification. Declare a new primitive +-- subprogram to write to the child extension. +-- +-- Add a public grandchild to the above package. Extend the extension of +-- the parent type with a record extension in the private part of the +-- specification. Declare a new primitive subprogram for this grandchild +-- extension. +-- +-- In the main program, "with" the grandchild. Access the primitive +-- operations from grandparent and parent package. +-- +-- TEST FILES: +-- This test depends on the following foundation code: +-- +-- FA11A00.A +-- +-- +-- CHANGE HISTORY: +-- 06 Dec 94 SAIC ACVC 2.0 +-- +--! + +package FA11A00.CA11A01_0 is -- Color_Widget_Pkg +-- This public child declares an extension from its parent. It +-- represents processing of widgets in a window system. + + type Widget_Color_Enum is (Black, Green, White); + + type Color_Widget is new Widget with -- Record extension of + record -- parent tagged type. + Color : Widget_Color_Enum; + end record; + + -- Inherits procedure Set_Width from Widget. + -- Inherits procedure Set_Height from Widget. + + -- To be inherited by its derivatives. + procedure Set_Color (The_Widget : in out Color_Widget; + C : in Widget_Color_Enum); + + procedure Set_Color_Widget (The_Widget : in out Color_Widget; + The_Width : in Widget_Length; + The_Height : in Widget_Length; + The_Color : in Widget_Color_Enum); + +end FA11A00.CA11A01_0; -- Color_Widget_Pkg + +--=======================================================================-- + +package body FA11A00.CA11A01_0 is -- Color_Widget_Pkg + + procedure Set_Color (The_Widget : in out Color_Widget; + C : in Widget_Color_Enum) is + begin + The_Widget.Color := C; + end Set_Color; + --------------------------------------------------------------- + procedure Set_Color_Widget (The_Widget : in out Color_Widget; + The_Width : in Widget_Length; + The_Height : in Widget_Length; + The_Color : in Widget_Color_Enum) is + begin + Set_Width (The_Widget, The_Width); -- Inherited from parent. + Set_Height (The_Widget, The_Height); -- Inherited from parent. + Set_Color (The_Widget, The_Color); + end Set_Color_Widget; + +end FA11A00.CA11A01_0; -- Color_Widget_Pkg + +--=======================================================================-- + +package FA11A00.CA11A01_0.CA11A01_1 is -- Label_Widget_Pkg +-- This public grandchild extends the extension from its parent. It +-- represents processing of widgets in a window system. + + -- Declaration used by private extension component. + subtype Widget_Label_Str is string (1 .. 10); + + type Label_Widget is new Color_Widget with private; + -- Record extension of parent tagged type. + + -- Inherits (inherited) procedure Set_Width from Color_Widget. + -- Inherits (inherited) procedure Set_Height from Color_Widget. + -- Inherits procedure Set_Color from Color_Widget. + -- Inherits procedure Set_Color_Widget from Color_Widget. + + procedure Set_Label_Widget (The_Widget : in out Label_Widget; + The_Width : in Widget_Length; + The_Height : in Widget_Length; + The_Color : in Widget_Color_Enum; + The_Label : in Widget_Label_Str); + + -- The following function is needed to verify the value of the + -- extension's private component. + + function Verify_Label (The_Widget : in Label_Widget; + The_Label : in Widget_Label_Str) return Boolean; + +private + type Label_Widget is new Color_Widget with + record + Label : Widget_Label_Str; + end record; + +end FA11A00.CA11A01_0.CA11A01_1; -- Label_Widget_Pkg + +--=======================================================================-- + +package body FA11A00.CA11A01_0.CA11A01_1 is -- Label_Widget_Pkg + + procedure Set_Label (The_Widget : in out Label_Widget; + L : in Widget_Label_Str) is + begin + The_Widget.Label := L; + end Set_Label; + -------------------------------------------------------------- + procedure Set_Label_Widget (The_Widget : in out Label_Widget; + The_Width : in Widget_Length; + The_Height : in Widget_Length; + The_Color : in Widget_Color_Enum; + The_Label : in Widget_Label_Str) is + begin + Set_Width (The_Widget, The_Width); -- Twice inherited. + Set_Height (The_Widget, The_Height); -- Twice inherited. + Set_Color (The_Widget, The_Color); -- Inherited from parent. + Set_Label (The_Widget, The_Label); + end Set_Label_Widget; + -------------------------------------------------------------- + function Verify_Label (The_Widget : in Label_Widget; + The_Label : in Widget_Label_Str) return Boolean is + begin + return (The_Widget.Label = The_Label); + end Verify_Label; + +end FA11A00.CA11A01_0.CA11A01_1; -- Label_Widget_Pkg + +--=======================================================================-- + +with FA11A00.CA11A01_0.CA11A01_1; -- Label_Widget_Pkg, + -- implicitly with Widget_Pkg, + -- implicitly with Color_Widget_Pkg +with Report; + +procedure CA11A01 is + + package Widget_Pkg renames FA11A00; + package Color_Widget_Pkg renames FA11A00.CA11A01_0; + package Label_Widget_Pkg renames FA11A00.CA11A01_0.CA11A01_1; + + use Widget_Pkg; -- All user-defined operators directly visible. + + Mail_Label : Label_Widget_Pkg.Widget_Label_Str := "Quick_Mail"; + + Default_Widget : Widget; + Black_Widget : Color_Widget_Pkg.Color_Widget; + Mail_Widget : Label_Widget_Pkg.Label_Widget; + +begin + + Report.Test ("CA11A01", "Check that type extended in a public " & + "child inherits primitive operations from its " & + "ancestor"); + + Set_Width (Default_Widget, 9); -- Call from parent. + Set_Height (Default_Widget, 10); -- Call from parent. + + If Default_Widget.Width /= Widget_Length (Report.Ident_Int (9)) or + Default_Widget.Height /= Widget_Length (Report.Ident_Int (10)) then + Report.Failed ("Incorrect result for Default_Widget"); + end if; + + Color_Widget_Pkg.Set_Color_Widget + (Black_Widget, 17, 18, Color_Widget_Pkg.Black); -- Explicitly declared. + + If Black_Widget.Width /= Widget_Length (Report.Ident_Int (17)) or + Black_Widget.Height /= Widget_Length (Report.Ident_Int (18)) or + Color_Widget_Pkg."/=" (Black_Widget.Color, Color_Widget_Pkg.Black) then + Report.Failed ("Incorrect result for Black_Widget"); + end if; + + Label_Widget_Pkg.Set_Label_Widget + (Mail_Widget, 15, 21, Color_Widget_Pkg.White, + "Quick_Mail"); -- Explicitly declared. + + If Mail_Widget.Width /= Widget_Length (Report.Ident_Int (15)) or + Mail_Widget.Height /= Widget_Length (Report.Ident_Int (21)) or + Color_Widget_Pkg."/=" (Mail_Widget.Color, Color_Widget_Pkg.White) or + not Label_Widget_Pkg.Verify_Label (Mail_Widget, Mail_Label) then + Report.Failed ("Incorrect result for Mail_Widget"); + end if; + + Report.Result; + +end CA11A01; diff --git a/gcc/testsuite/ada/acats/tests/ca/ca11a02.a b/gcc/testsuite/ada/acats/tests/ca/ca11a02.a new file mode 100644 index 000000000..e7c161423 --- /dev/null +++ b/gcc/testsuite/ada/acats/tests/ca/ca11a02.a @@ -0,0 +1,156 @@ +-- CA11A02.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 type extended in a client of a public child inherits +-- primitive operations from parent. +-- +-- TEST DESCRIPTION: +-- Declare a root tagged type in a package specification. Declare two +-- primitive subprograms for the type (foundation code). +-- +-- Add a public child to the above package. Extend the root type with +-- a record extension in the specification. Declare a new primitive +-- subprogram to write to the child extension. +-- +-- In the main program, "with" the child. Declare an extension of +-- the child extension. Access the primitive operations from both +-- parent and child packages. +-- +-- TEST FILES: +-- This test depends on the following foundation code: +-- +-- FA11A00.A +-- +-- +-- CHANGE HISTORY: +-- 06 Dec 94 SAIC ACVC 2.0 +-- 20 Dec 94 SAIC Moved declaration of Label_Widget to library level +-- +--! + +package FA11A00.CA11A02_0 is -- Color_Widget_Pkg +-- This public child declares an extension from its parent. It +-- represents processing of widgets in a window system. + + type Widget_Color_Enum is (Black, Green, White); + + type Color_Widget is new Widget with -- Record extension of + record -- parent tagged type. + Color : Widget_Color_Enum; + end record; + + -- Inherits procedure Set_Width from parent. + -- Inherits procedure Set_Height from parent. + + -- To be inherited by its derivatives. + procedure Set_Color (The_Widget : in out Color_Widget; + C : in Widget_Color_Enum); + +end FA11A00.CA11A02_0; -- Color_Widget_Pkg + +--=======================================================================-- + +package body FA11A00.CA11A02_0 is -- Color_Widget_Pkg + + procedure Set_Color (The_Widget : in out Color_Widget; + C : in Widget_Color_Enum) is + begin + The_Widget.Color := C; + end Set_Color; + +end FA11A00.CA11A02_0; -- Color_Widget_Pkg + +--=======================================================================-- + +with FA11A00.CA11A02_0; -- Color_Widget_Pkg. + +package CA11A02_1 is + + type Label_Widget (Str_Disc : Integer) is new + FA11A00.CA11A02_0.Color_Widget with + record + Label : String (1 .. Str_Disc); + end record; + + -- Inherits (inherited) procedure Set_Width from Color_Widget. + -- Inherits (inherited) procedure Set_Height from Color_Widget. + -- Inherits procedure Set_Color from Color_Widget. + +end CA11A02_1; + +--=======================================================================-- + +with FA11A00.CA11A02_0; -- Color_Widget_Pkg, + -- implicitly with Widget_Pkg +with CA11A02_1; + +with Report; + +procedure CA11A02 is + + package Widget_Pkg renames FA11A00; + package Color_Widget_Pkg renames FA11A00.CA11A02_0; + + use Widget_Pkg; -- All user-defined operators directly visible. + + procedure Set_Label (The_Widget : in out CA11A02_1.Label_Widget; + L : in String) is + begin + The_Widget.Label := L; + end Set_Label; + --------------------------------------------------------- + procedure Set_Widget (The_Widget : in out CA11A02_1.Label_Widget; + The_Width : in Widget_Length; + The_Height : in Widget_Length; + The_Color : in + Color_Widget_Pkg.Widget_Color_Enum; + The_Label : in String) is + begin + CA11A02_1.Set_Width (The_Widget, The_Width); -- Twice inherited. + CA11A02_1.Set_Height (The_Widget, The_Height); -- Twice inherited. + CA11A02_1.Set_Color (The_Widget, The_Color); -- Inherited. + Set_Label (The_Widget, The_Label); -- Explicitly declared. + end Set_Widget; + + White_Widget : CA11A02_1.Label_Widget (11); + +begin + + Report.Test ("CA11A02", "Check that a type extended in a client of " & + "a public child inherits primitive operations from parent"); + + Set_Widget (White_Widget, 15, 21, Color_Widget_Pkg.White, "Alarm_Clock"); + + If White_Widget.Width /= Widget_Length (Report.Ident_Int (15)) or + White_Widget.Height /= Widget_Length (Report.Ident_Int (21)) or + Color_Widget_Pkg."/=" (White_Widget.Color, Color_Widget_Pkg.White) or + White_Widget.Label /= "Alarm_Clock" then + Report.Failed ("Incorrect result for White_Widget"); + end if; + + Report.Result; + +end CA11A02; diff --git a/gcc/testsuite/ada/acats/tests/ca/ca11b01.a b/gcc/testsuite/ada/acats/tests/ca/ca11b01.a new file mode 100644 index 000000000..8d6de02f1 --- /dev/null +++ b/gcc/testsuite/ada/acats/tests/ca/ca11b01.a @@ -0,0 +1,208 @@ +-- CA11B01.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 type derived in a public child inherits primitive +-- operations from parent. +-- +-- TEST DESCRIPTION: +-- Declare a root record type with discriminant in a package +-- specification. Declare a primitive subprogram for the type +-- (foundation code). +-- +-- Add a public child to the above package. Derive a new type +-- with constraint to the discriminant record type from the parent +-- package. Declare a new primitive subprogram to write to the child +-- derived type. +-- +-- Add a new public child to the above package. This grandchild package +-- derives a new type using the record type from the above package. +-- Declare a new primitive subprogram to write to the grandchild derived +-- type. +-- +-- In the main program, "with" the grandchild. Access the inherited +-- operations from grandparent, parent, and grandchild packages. +-- +-- TEST FILES: +-- This test depends on the following foundation code: +-- +-- FA11B00.A +-- +-- +-- CHANGE HISTORY: +-- 06 Dec 94 SAIC ACVC 2.0 +-- +--! + +-- Child package of FA11B00. +package FA11B00.CA11B01_0 is -- Application_Two_Widget +-- This public child declares a derived type from its parent. It +-- represents processing of widgets in a window system. + + type App2_Widget is new App1_Widget (Maximum_Size => 5000); + -- Inherits procedure Create_Widget from parent. + + -- Primitive operation of type App2_Widget. + -- To be inherited by its children derivatives. + procedure App2_Widget_Specific_Oper (The_Widget : in out App2_Widget; + Loc : in Widget_Location); + +end FA11B00.CA11B01_0; -- Application_Two_Widget + +--=======================================================================-- + +package body FA11B00.CA11B01_0 is -- Application_Two_Widget + + procedure App2_Widget_Specific_Oper + (The_Widget : in out App2_Widget; + Loc : in Widget_Location) is + begin + The_Widget.Location := Loc; + end App2_Widget_Specific_Oper; + +end FA11B00.CA11B01_0; -- Application_Two_Widget + +--=======================================================================-- + +-- Grandchild package of FA11B00, child package of FA11B00.CA11B01_0. +package FA11B00.CA11B01_0.CA11B01_1 is -- Application_Three_Widget +-- This public grandchild declares a derived type from its parent. It +-- represents processing of widgets in a window system. + + type App3_Widget is new App2_Widget; -- Derived record of App2_Widget. + + -- Inherits (inherited) procedure Create_Widget from Application_One_Widget. + -- Inherits procedure App2_Widget_Specific_Oper from App2_Widget. + + -- Primitive operation of type App3_Widget. + procedure App3_Widget_Specific_Oper (The_Widget : in out App3_Widget; + S : in Widget_Size); + +end FA11B00.CA11B01_0.CA11B01_1; -- Application_Three_Widget + +--=======================================================================-- + +package body FA11B00.CA11B01_0.CA11B01_1 is -- Application_Three_Widget + + procedure App3_Widget_Specific_Oper + (The_Widget : in out App3_Widget; + S : in Widget_Size) is + begin + The_Widget.Size := S; + end App3_Widget_Specific_Oper; + +end FA11B00.CA11B01_0.CA11B01_1; -- Application_Three_Widget + +--=======================================================================-- + +with FA11B00.CA11B01_0.CA11B01_1; -- Application_Three_Widget, + -- implicitly with Application_Two_Widget, + -- implicitly with Application_Three_Widget. +with Report; + +procedure CA11B01 is + + package Application_One_Widget renames FA11B00; + package Application_Two_Widget renames FA11B00.CA11B01_0; + package Application_Three_Widget renames FA11B00.CA11B01_0.CA11B01_1; + + use Application_One_Widget; + use Application_Two_Widget; + use Application_Three_Widget; + +begin + + Report.Test ("CA11B01", "Check that a type derived in a public " & + "child inherits primitive operations from parent"); + + Application_One_Subtest: + declare + White_Widget : App1_Widget; + + begin + -- perform an App1_Widget specific operation. + App1_Widget_Specific_Oper (C => White, L => "Line Editor ", + The_Widget => White_Widget, I => 10); + + If White_Widget.Color /= White or + White_Widget.Id /= Widget_ID + (Report.Ident_Int (10)) or + White_Widget.Label /= "Line Editor " then + Report.Failed ("Incorrect result for White_Widget"); + end if; + + end Application_One_Subtest; + --------------------------------------------------------------- + Application_Two_Subtest: + declare + Amber_Widget : App2_Widget; + + begin + App1_Widget_Specific_Oper (Amber_Widget, I => 11, + C => Amber, L => "Alarm_Clock "); + -- Inherited from Application_One_Widget. + + -- perform an App2_Widget specific operation. + App2_Widget_Specific_Oper (The_Widget => Amber_Widget, Loc => (380,512)); + + If Amber_Widget.Color /= Amber or + Amber_Widget.Id /= Widget_ID (Report.Ident_Int (11)) or + Amber_Widget.Label /= "Alarm_Clock " or + Amber_Widget.Location /= (380,512) then + Report.Failed ("Incorrect result for Amber_Widget"); + end if; + + end Application_Two_Subtest; + --------------------------------------------------------------- + Application_Three_Subtest: + declare + Green_Widget : App3_Widget; + + begin + App1_Widget_Specific_Oper (Green_Widget, 100, Green, + "Screen Editor "); + -- Inherited (inherited) from Basic_Widget. + + -- perform an App2_Widget specific operation. + App2_Widget_Specific_Oper (Loc => (1024,760), + The_Widget => Green_Widget); + -- Inherited from App_1_Widget. + + -- perform an App3_Widget specific operation. + App3_Widget_Specific_Oper (Green_Widget, S => (100,100)); + + If Green_Widget.Color /= Green or + Green_Widget.Id /= Widget_ID (Report.Ident_Int (100)) or + Green_Widget.Label /= "Screen Editor " or + Green_Widget.Location /= (1024,760) or + Green_Widget.Size /= (100,100) then + Report.Failed ("Incorrect result for Green_Widget"); + end if; + + end Application_Three_Subtest; + + Report.Result; + +end CA11B01; diff --git a/gcc/testsuite/ada/acats/tests/ca/ca11b02.a b/gcc/testsuite/ada/acats/tests/ca/ca11b02.a new file mode 100644 index 000000000..0743f7333 --- /dev/null +++ b/gcc/testsuite/ada/acats/tests/ca/ca11b02.a @@ -0,0 +1,169 @@ +-- CA11B02.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 type derived in a client of a public child inherits +-- primitive operations from parent. +-- +-- TEST DESCRIPTION: +-- Declare a root record type with discriminant in a package +-- specification. Declare a primitive subprogram for the type +-- (foundation code). +-- +-- Add a public child to the above package. Derive a new type +-- with constraint to the discriminant record type from the parent +-- package. Declare a new primitive subprogram to write to the child +-- derived type. +-- +-- In the main program, "with" the child. Derive a new type using the +-- record type from the child package. Access the inherited operations +-- from both parent and child packages. +-- +-- TEST FILES: +-- This test depends on the following foundation code: +-- +-- FA11B00.A +-- +-- +-- CHANGE HISTORY: +-- 06 Dec 94 SAIC ACVC 2.0 +-- +--! + +-- Child package of FA11B00. +package FA11B00.CA11B02_0 is -- Application_Two_Widget +-- This public child declares a derived type from its parent. It +-- represents processing of widgets in a window system. + + -- Dimension of app2_widget is limited to 5000 pixels. + + type App2_Widget is new App1_Widget (Maximum_Size => 5000); + -- Derived record of parent type. + + -- Inherits procedure App1_Widget_Specific_Oper from parent. + + + -- Primitive operation of type App2_Widget. + + procedure App2_Widget_Specific_Op1 (The_Widget : in out App2_Widget; + S : in Widget_Size); + + -- Primitive operation of type App2_Widget. + + procedure App2_Widget_Specific_Op2 (The_Widget : in out App2_Widget; + Loc : in Widget_Location); + +end FA11B00.CA11B02_0; -- Application_Two_Widget + + +--=======================================================================-- + + +package body FA11B00.CA11B02_0 is -- Application_Two_Widget + + procedure App2_Widget_Specific_Op1 (The_Widget : in out App2_Widget; + S : in Widget_Size) is + begin + The_Widget.Size := S; + end App2_Widget_Specific_Op1; + + --==============================================-- + + procedure App2_Widget_Specific_Op2 (The_Widget : in out App2_Widget; + Loc : in Widget_Location) is + begin + The_Widget.Location := Loc; + end App2_Widget_Specific_Op2; + +end FA11B00.CA11B02_0; -- Application_Two_Widget + + +--=======================================================================-- + +with FA11B00.CA11B02_0; -- Application_Two_Widget + -- implicitly with Application_One_Widget. +with Report; + +procedure CA11B02 is + + package Application_One_Widget renames FA11B00; + + package Application_Two_Widget renames FA11B00.CA11B02_0; + + use Application_One_Widget ; + use Application_Two_Widget ; + + type Emulator_Widget is new App2_Widget; -- Derived record of + -- parent type. + + White_Widget, Amber_Widget : Emulator_Widget; + + +begin + + Report.Test ("CA11B02", "Check that a type derived in client of a " & + "public child inherits primitive operations from parent"); + + App1_Widget_Specific_Oper (C => White, L => "Line Editor ", + The_Widget => White_Widget, I => 10); + -- Inherited from Application_One_Widget. + If White_Widget.Color /= White or + White_Widget.Id /= Widget_ID (Report.Ident_Int (10)) or + White_Widget.Label /= "Line Editor " + then + Report.Failed ("Incorrect result for White_Widget"); + end if; + + -- perform an App2_Widget specific operation. + + App2_Widget_Specific_Op1 (White_Widget, S => (100, 200)); + + If White_Widget.Size.X_Length /= 100 or + White_Widget.Size.Y_Length /= 200 + then + Report.Failed ("Incorrect size for White_Widget"); + end if; + + App1_Widget_Specific_Oper (Amber_Widget, 5, Amber, "Screen Editor "); + -- Inherited from Application_One_Widget. + + -- perform an App2_Widget specific operations. + + App2_Widget_Specific_Op1 (S => (1024,100), The_Widget => Amber_Widget); + App2_Widget_Specific_Op2 (Amber_Widget, (1024, 760)); + + If Amber_Widget.Color /= Amber or + Amber_Widget.Id /= Widget_ID (Report.Ident_Int (5)) or + Amber_Widget.Label /= "Screen Editor " or + Amber_Widget.Size /= (1024,100) or + Amber_Widget.Location.X_Location /= 1024 or + Amber_Widget.Location.Y_Location /= 760 + then + Report.Failed ("Incorrect result for Amber_Widget"); + end if; + + Report.Result; + +end CA11B02; diff --git a/gcc/testsuite/ada/acats/tests/ca/ca11c01.a b/gcc/testsuite/ada/acats/tests/ca/ca11c01.a new file mode 100644 index 000000000..195ec2d40 --- /dev/null +++ b/gcc/testsuite/ada/acats/tests/ca/ca11c01.a @@ -0,0 +1,170 @@ +-- CA11C01.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 when primitive operations declared in a child package +-- override operations declared in ancestor packages, a client of the +-- child package inherits the operations correctly. +-- +-- TEST DESCRIPTION: +-- +-- This test builds on the foundation code file (FA11C00) that contains +-- a parent package, child package, and grandchild package. The parent +-- package declares a tagged type and primitive operation. The child +-- package extends the type, and overrides the primitive operation. The +-- grandchild package does the same. +-- +-- The test procedure "withs" the grandchild package, and receives +-- visibility to all of its ancestor packages, types and operations. +-- Three procedures, each with a formal parameter of a specific type are +-- defined. Each of these invokes a particular version of the overridden +-- primitive operation Image. Calls to these local procedures are made, +-- with objects of each of the tagged types as parameters, and the global +-- variable is finally examined to ensure that the correct version of +-- primitive operation was inherited by the client and invoked by the +-- call. +-- +-- TEST FILES: +-- This test depends on the following foundation code: +-- +-- FA11C00.A +-- +-- +-- CHANGE HISTORY: +-- 06 Dec 94 SAIC ACVC 2.0 +-- +--! + +with FA11C00_0.FA11C00_1.FA11C00_2; -- Package Animal.Mammal.Primate +with Report; + +procedure CA11C01 is + + package Animal_Package renames FA11C00_0; + package Mammal_Package renames FA11C00_0.FA11C00_1; + package Primate_Package renames FA11C00_0.FA11C00_1.FA11C00_2; + + Max_Animals : constant := 3; + + subtype Data_String is String (1 .. 37); + type Data_Base_Type is array (1 .. Max_Animals) of Data_String; + + Zoo_Data_Base : Data_Base_Type := (others => (others => ' ')); + -- Global variable. + + Salmon : Animal_Package.Animal := (Common_Name => "Chinook Salmon ", + Weight => 10); + + Platypus : Mammal_Package.Mammal := (Common_Name => "Tasmanian Platypus ", + Weight => 13, + Hair_Color => Mammal_Package.Brown); + + Orangutan : Primate_Package.Primate := + (Common_Name => "Sumatran Orangutan ", + Weight => 220, + Hair_Color => Mammal_Package.Red, + Habitat => Primate_Package.Arboreal); +begin + + Report.Test ("CA11C01", "Check that when primitive operations declared " & + "in a child package override operations declared " & + "in ancestor packages, a client of the child " & + "package inherits the operations correctly"); + + declare + + use Animal_Package, Mammal_Package, Primate_Package; + + -- The function Image has been overridden in the child and grandchild + -- packages, but the client has inherited all versions of the function, + -- and can successfully use them to enter data into the database. + -- Each of the following procedures updates the global variable + -- Zoo_Data_Base. + + procedure Enter_Animal_Data (A : Animal; I : Integer) is + begin + Zoo_Data_Base (I) := Image (A); + end Enter_Animal_Data; + + procedure Enter_Mammal_Data (M : Mammal; I : Integer) is + begin + Zoo_Data_Base (I) := Image (M); + end Enter_Mammal_Data; + + procedure Enter_Primate_Data (P : Primate; I : Integer) is + begin + Zoo_Data_Base (I) := Image (P); + end Enter_Primate_Data; + + begin + + -- Verify initial test conditions. + + if not (Zoo_Data_Base(1)(1..6) = " ") + or else + (Zoo_Data_Base(2)(1..6) /= " ") + or else + (Zoo_Data_Base(3)(1..6) /= " ") + then + Report.Failed ("Initial condition failure"); + end if; + + + -- Enter data from all three animals into the zoo database. + + Enter_Animal_Data (A => Salmon, I => 1); -- First entry in database. + Enter_Mammal_Data (M => Platypus, I => 2); -- Second entry. + Enter_Primate_Data (P => Orangutan, I => 3); -- Third entry. + + -- Verify the correct version of the overridden function Image was used + -- for entering the specific data. + + if Zoo_Data_Base(1)(1 .. 6) /= "Animal" + or else + Zoo_Data_Base(1)(26 .. 31) /= "Salmon" + then + Report.Failed ("Incorrect version of Image for parent type"); + end if; + + if (Zoo_Data_Base(2)(1 .. 6) /= "Mammal") + or + (Zoo_Data_Base(2)(28 .. 35) /= "Platypus") + then + Report.Failed ("Incorrect version of Image for child type"); + end if; + + if ((Zoo_Data_Base(3)(1 .. 7) /= "Primate") + or + (Zoo_Data_Base(3)(27 .. 35) /= "Orangutan")) + then + Report.Failed ("Incorrect version of Image for grandchild type"); + end if; + + end; + + + Report.Result; + +end CA11C01; diff --git a/gcc/testsuite/ada/acats/tests/ca/ca11c02.a b/gcc/testsuite/ada/acats/tests/ca/ca11c02.a new file mode 100644 index 000000000..7d8749328 --- /dev/null +++ b/gcc/testsuite/ada/acats/tests/ca/ca11c02.a @@ -0,0 +1,158 @@ +-- CA11C02.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 primitive operations declared in a child package +-- override operations declared in ancestor packages, and that +-- operations on class-wide types defined in the ancestor packages +-- dispatch as appropriate to these overriding implementations. +-- +-- TEST DESCRIPTION: +-- +-- This test builds on the foundation code file (FA11C00) that contains +-- a parent package, child package, and grandchild package. The parent +-- package declares a tagged type and primitive operation. The child +-- package extends the type, and overrides the primitive operation. The +-- grandchild package does the same. +-- +-- The test procedure "withs" the grandchild package, and receives +-- visibility to all of its ancestor packages, types and operations. +-- A procedure with a formal class-wide parameter is defined that will +-- allow for dispatching calls to the overridden primitive operations, +-- based on the specific type of the actual parameter. The primitive +-- operations provide a string value to update a global string array +-- variable. Calls to the local procedure are made, with objects of each +-- of the tagged types as parameters, and the global variable is finally +-- examined to ensure that the correct version of primitive operation was +-- dispatched correctly. +-- +-- TEST FILES: +-- This test depends on the following foundation code: +-- +-- FA11C00.A +-- +-- +-- CHANGE HISTORY: +-- 06 Dec 94 SAIC ACVC 2.0 +-- +--! + +with FA11C00_0.FA11C00_1.FA11C00_2; -- Package Animal.Mammal.Primate +with Report; + +procedure CA11C02 is + + package Animal_Package renames FA11C00_0; + package Mammal_Package renames FA11C00_0.FA11C00_1; + package Primate_Package renames FA11C00_0.FA11C00_1.FA11C00_2; + + Max_Animals : constant := 3; + + type Data_Base_Type is array (1 .. Max_Animals) of String (1 .. 37); + + Zoo_Data_Base : Data_Base_Type := (others => (others => ' ')); + -- Global variable. + + Macaw : Animal_Package.Animal := (Common_Name => "Scarlet Macaw ", + Weight => 2); + + Manatee : Mammal_Package.Mammal := (Common_Name => "Southern Manatee ", + Weight => 230, + Hair_Color => Mammal_Package.Brown); + + Lemur : Primate_Package.Primate := + (Common_Name => "Ring-Tailed Lemur ", + Weight => 5, + Hair_Color => Mammal_Package.Black, + Habitat => Primate_Package.Arboreal); +begin + + Report.Test ("CA11C02", "Check that primitive operations declared " & + "in a child package override operations declared " & + "in ancestor packages, and that operations " & + "on class-wide types defined in the ancestor " & + "packages dispatch as appropriate to these " & + "overriding implementations"); + + declare + + use Animal_Package, Mammal_Package, Primate_Package; + + -- The following procedure updates the global variable Zoo_Data_Base. + + procedure Enter_Data (A : Animal'Class; I : Integer) is + begin + Zoo_Data_Base (I) := Image (A); + end Enter_Data; + + begin + + -- Verify initial test conditions. + + if not (Zoo_Data_Base(1)(1..6) = " ") + or not + (Zoo_Data_Base(2)(1..6) = " ") + or not + (Zoo_Data_Base(3)(1..6) = " ") + then + Report.Failed ("Initial condition failure"); + end if; + + + -- Enter data from all three animals into the zoo database. + + Enter_Data (Macaw, 1); -- First entry in database. + Enter_Data (A => Manatee, I => 2); -- Second entry. + Enter_Data (Lemur, I => 3); -- Third entry. + + -- Verify the correct version of the overridden function Image was used + -- for entering the specific data. + + if not (Zoo_Data_Base(1)(1 .. 6) = "Animal") + or not + (Zoo_Data_Base(1)(26 .. 30) = "Macaw") + then + Report.Failed ("Incorrect version of Image for parent type"); + end if; + + if not (Zoo_Data_Base(2)(1 .. 6) = "Mammal" + and + Zoo_Data_Base(2)(27 .. 33) = "Manatee") + then + Report.Failed ("Incorrect version of Image for child type"); + end if; + + if not ((Zoo_Data_Base(3)(1 .. 7) = "Primate") + and + (Zoo_Data_Base(3)(30 .. 34) = "Lemur")) + then + Report.Failed ("Incorrect version of Image for grandchild type"); + end if; + + end; + + Report.Result; + +end CA11C02; diff --git a/gcc/testsuite/ada/acats/tests/ca/ca11c03.a b/gcc/testsuite/ada/acats/tests/ca/ca11c03.a new file mode 100644 index 000000000..b75a66034 --- /dev/null +++ b/gcc/testsuite/ada/acats/tests/ca/ca11c03.a @@ -0,0 +1,186 @@ +-- CA11C03.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 when a child unit is "withed", visibility is obtained to +-- all ancestor units named in the expanded name of the "withed" child +-- unit. Check that when the parent unit is "used", the simple name of +-- a "withed" child unit is made directly visible. +-- +-- TEST DESCRIPTION: +-- To satisfy the first part of the objective, various references are +-- made to types and functions declared in the ancestor packages of the +-- foundation code package hierarchy. Since the grandchild library unit +-- package has been "withed" by this test, the visibility of these +-- components demonstrates that visibility of the ancestor package names +-- is provided when the expanded name of a child library unit is "withed". +-- +-- The declare block in the test program includes a "use" clause of the +-- parent package (FA11C00_0.FA11C00_1) of the "withed" child package. +-- As a result, the simple name of the child package (FA11C00_2) is +-- directly visible. The type and function declared in the child +-- package are now visible when qualified with the simple name of the +-- "withed" package (FA11C00_2). +-- +-- This test simulates the formatting of data strings, based on the +-- component fields of a "doubly-extended" tagged record type. +-- +-- TEST FILES: +-- This test depends on the following foundation code: +-- +-- FA11C00.A +-- +-- +-- CHANGE HISTORY: +-- 06 Dec 94 SAIC ACVC 2.0 +-- +--! + +with FA11C00_0.FA11C00_1.FA11C00_2; -- "with" of child library package + -- Animal.Mammal.Primate. + -- This will be used in conjunction with + -- a "use" of FA11C00_0.FA11C00_1 below + -- to verify a portion of the objective. +with Report; + +procedure CA11C03 is + + Blank_Name_String : constant FA11C00_0.Species_Name_Type := (others => ' '); + -- Visibility of grandparent package. + -- The package FA11C00_0 is visible since + -- it is an ancestor that is mentioned in + -- the expanded name of its "withed" + -- grandchild package. + + Blank_Hair_Color : + String (1..FA11C00_0.FA11C00_1.Hair_Color_Type'Width) := (others => ' '); + -- Visibility of parent package. + -- The package FA11C00_0.FA11C00_1 is + -- visible due to the "with" of its + -- child package. + + subtype Data_String_Type is String (1 .. 60); + + TC_Result_String : Data_String_Type := (others => ' '); + + -- + + function Format_Primate_Data (Name : String := Blank_Name_String; + Hair : String := Blank_Hair_Color) + return Data_String_Type is + + Pos : Integer := 1; + Hair_Color_Field_Separator : constant String := " Hair Color: "; + + Result_String : Data_String_Type := (others => ' '); + + begin + Result_String (Pos .. Name'Length) := Name; -- Enter name at start + -- of string. + Pos := Pos + Name'Length; -- Increment counter to + -- next blank position. + Result_String + (Pos .. Pos + Hair_Color_Field_Separator'Length + Hair'Length - 1) := + Hair_Color_Field_Separator & Hair; -- Include hair color data + -- in result string. + return (Result_String); + end Format_Primate_Data; + + +begin + + Report.Test ("CA11C03", "Check that when a child unit is WITHED, " & + "visibility is obtained to all ancestor units " & + "named in the expanded name of the WITHED child " & + "unit. Check that when the parent unit is USED, " & + "the simple name of a WITHED child unit is made " & + "directly visible" ); + + declare + use FA11C00_0.FA11C00_1; -- This "use" clause will allow direct + -- visibility to the simple name of + -- package FA11C00_0.FA11C00_1.FA11C00_2, + -- since this child package was "withed" by + -- the main program. + + Tarsier : FA11C00_2.Primate := (Common_Name => "East-Indian Tarsier ", + Weight => 7, + Hair_Color => Brown, + Habitat => FA11C00_2.Arboreal); + + -- Demonstrates visibility of package + -- FA11C00_0.FA11C00_1.FA11C00_2. + -- + -- Type Primate referenced with the simple + -- name of package FA11C00_2 only. + -- + -- Simple name of package FA11C00_2 is + -- directly visible through "use" of parent. + + begin + + -- Verify that the Format_Primate_Data function will return a blank + -- filled string when no parameters are provided in the call. + + TC_Result_String := Format_Primate_Data; + + if (TC_Result_String (1 .. 20) /= Blank_Name_String) then + Report.Failed ("Incorrect initialization value from function"); + end if; + + + -- Use function Format_Primate_Data to return a formatted data string. + + TC_Result_String := + Format_Primate_Data + (Name => FA11C00_2.Image (Tarsier), + -- Function returns a 37 character string + -- value. + Hair => Hair_Color_Type'Image(Tarsier.Hair_Color)); + -- The Hair_Color_Type is referenced + -- directly, without package + -- FA11C00_0.FA11C00_1 qualifier. + -- No qualification of Hair_Color_Type is + -- needed due to "use" clause. + + -- Note that the result of calling 'Image + -- with an enumeration type argument + -- results in an upper-case string. + -- (See conditional statement below.) + + -- Verify the results of the function call. + + if not (TC_Result_String (1 .. 37) = + "Primate Species: East-Indian Tarsier " and then + TC_Result_String (38 .. 55) = + " Hair Color: BROWN") then + Report.Failed ("Incorrect result returned from function call"); + end if; + + end; + + Report.Result; + +end CA11C03; diff --git a/gcc/testsuite/ada/acats/tests/ca/ca11d010.a b/gcc/testsuite/ada/acats/tests/ca/ca11d010.a new file mode 100644 index 000000000..7ea0e2267 --- /dev/null +++ b/gcc/testsuite/ada/acats/tests/ca/ca11d010.a @@ -0,0 +1,119 @@ +-- CA11D010.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: +-- See CA11D013.AM +-- +-- TEST DESCRIPTION: +-- See CA11D013.AM +-- +-- TEST FILES: +-- The following files comprise this test: +-- +-- FA11D00.A +-- => CA11D010.A +-- CA11D011.A +-- CA11D012.A +-- CA11D013.AM +-- +-- CHANGE HISTORY: +-- 06 Dec 94 SAIC ACVC 2.0 +-- 26 Apr 96 SAIC ACVC 2.1: Modified prologue. +-- +--! + +-- Child package of FA11D00. + +package FA11D00.CA11D010 is -- Add_Subtract_Complex + + procedure Add (Left, Right : in Complex_Type; -- Add two complex + C : out Complex_Type); -- numbers. + + function Subtract (Left, Right : Complex_Type) -- Subtract two + return Complex_Type; -- complex numbers. + + + +end FA11D00.CA11D010; -- Add_Subtract_Complex + +--=======================================================================-- + +with Report; + +package body FA11D00.CA11D010 is -- Add_Subtract_Complex + + procedure Add (Left, Right : in Complex_Type; + C : out Complex_Type) is + begin + -- Zero is declared in parent package. + + if Left.Real < Zero.Real or else Right.Real < Zero.Real + or else Left.Imag < Zero.Imag or else Right.Imag < Zero.Imag then + raise Add_Error; -- Reference to exception in parent package. + Report.Failed ("Program control not transferred by raise in " & + "procedure Add"); + else + C.Real := (Left.Real + Right.Real); + C.Imag := (Left.Imag + Right.Imag); + end if; + + exception + when Add_Error => + TC_Handled_In_Child_Pkg_Proc := true; + C := Check_Value; -- Reference to object in parent package. + raise; -- Reraise the Add_Error exception in the subtest. + Report.Failed ("Exception not reraised in handler"); + + when others => + Report.Failed ("Unexpected exception raised in Add"); + + end Add; + ----------------------------------------------------------- + function Subtract (Left, Right : Complex_Type) + return Complex_Type is + begin + -- Zero is declared in parent package. + if Left.Real < Zero.Real or Right.Real < Zero.Real + or Left.Imag < Zero.Imag or Right.Imag < Zero.Imag then + raise Subtract_Error; -- Reference to exception in parent package. + Report.Failed ("Program control not transferred by raise in " & + "function Subtract"); + else + return ( Real => (Left.Real - Right.Real), + Imag => (Left.Imag - Right.Imag) ); + end if; + + exception + when Subtract_Error => + Report.Comment ("Exception is properly handled in Subtract"); + TC_Handled_In_Child_Pkg_Func := true; + return Check_Value; + + when others => + Report.Failed ("Unexpected exception raised in Subtract"); + + end Subtract; + +end FA11D00.CA11D010; -- Add_Subtract_Complex diff --git a/gcc/testsuite/ada/acats/tests/ca/ca11d011.a b/gcc/testsuite/ada/acats/tests/ca/ca11d011.a new file mode 100644 index 000000000..014f74be7 --- /dev/null +++ b/gcc/testsuite/ada/acats/tests/ca/ca11d011.a @@ -0,0 +1,79 @@ +-- CA11D011.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: +-- See CA11D013.AM +-- +-- TEST DESCRIPTION: +-- See CA11D013.AM +-- +-- TEST FILES: +-- The following files comprise this test: +-- +-- FA11D00.A +-- CA11D010.A +-- => CA11D011.A +-- CA11D012.A +-- CA11D013.AM +-- +-- CHANGE HISTORY: +-- 06 Dec 94 SAIC ACVC 2.0 +-- 21 Dec 94 SAIC Declared child procedure specification +-- 26 Apr 96 SAIC ACVC 2.1: Modified prologue. +-- +--! + +with Report; + + +-- Child procedure of FA11D00. + +procedure FA11D00.CA11D011 (Left, Right : in Complex_Type; + C : out Complex_Type); + +--=======================================================================-- + +procedure FA11D00.CA11D011 (Left, Right : in Complex_Type; + C : out Complex_Type) is +-- Multiply_Complex. + +begin + -- Zero is declared in parent package. + + if Left.Real < Zero.Real or Right.Imag < Zero.Imag then + raise Multiply_Error; -- Reference to exception in parent package. + Report.Failed ("Program control not transferred by raise in " & + "child procedure FA11D00.CA11D011"); + else + C.Real := (Left.Real * Right.Real); + C.Imag := (Left.Imag * Right.Imag); + end if; + + exception + when others => + TC_Handled_In_Child_Sub := true; + C := Check_Value; -- Reference to object in parent package. + +end FA11D00.CA11D011; -- Multiply_Complex diff --git a/gcc/testsuite/ada/acats/tests/ca/ca11d012.a b/gcc/testsuite/ada/acats/tests/ca/ca11d012.a new file mode 100644 index 000000000..1bb3bd7ac --- /dev/null +++ b/gcc/testsuite/ada/acats/tests/ca/ca11d012.a @@ -0,0 +1,73 @@ +-- CA11D012.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: +-- See CA11D013.AM +-- +-- TEST DESCRIPTION: +-- See CA11D013.AM +-- +-- TEST FILES: +-- The following files comprise this test: +-- +-- FA11D00.A +-- CA11D010.A +-- CA11D011.A +-- => CA11D012.A +-- CA11D013.AM +-- +-- CHANGE HISTORY: +-- 06 Dec 94 SAIC ACVC 2.0 +-- 21 Dec 94 SAIC Declared child function specification +-- 26 Apr 96 SAIC ACVC 2.1: Modified prologue. +-- +--! + +with Report; + +-- Child function of FA11D00. +-- Does not divide zero complex numbers. + +function FA11D00.CA11D012 (Left, Right : Complex_Type) + return Complex_Type; + +--=======================================================================-- + +function FA11D00.CA11D012 (Left, Right : Complex_Type) + return Complex_Type is -- Divide_Complex + +begin + -- Zero is declared in parent package. + + if Right.Real = Zero.Real or Right.Imag = Zero.Imag then + raise Divide_Error; -- Reference to exception in parent package. + Report.Failed ("Program control not transferred by raise in " & + "child function FA11D00.CA11D012"); + else + return ( Real => (Left.Real / Right.Real), + Imag => (Left.Imag / Right.Imag) ); + end if; + +end FA11D00.CA11D012; -- Divide_Complex diff --git a/gcc/testsuite/ada/acats/tests/ca/ca11d013.am b/gcc/testsuite/ada/acats/tests/ca/ca11d013.am new file mode 100644 index 000000000..6cbd3bbcc --- /dev/null +++ b/gcc/testsuite/ada/acats/tests/ca/ca11d013.am @@ -0,0 +1,256 @@ +-- CA11D013.AM +-- +-- Grant of Unlimited Rights +-- +-- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687, +-- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained +-- unlimited rights in the software and documentation contained herein. +-- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making +-- this public release, the Government intends to confer upon all +-- recipients unlimited rights equal to those held by the Government. +-- These rights include rights to use, duplicate, release or disclose the +-- released technical data and computer software in whole or in part, in +-- any manner and for any purpose whatsoever, and to have or permit others +-- to do so. +-- +-- DISCLAIMER +-- +-- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR +-- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED +-- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF 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 child unit can raise an exception that is declared in +-- parent. +-- +-- TEST DESCRIPTION: +-- Declare a package which defines complex number abstraction with +-- user-defined exceptions (foundation code). +-- +-- Add a public child package to the above package. Declare two +-- subprograms for the parent type. Each of the subprograms raises a +-- different exception, based on the value of an input parameter. +-- +-- Add a public child procedure to the foundation package. This +-- procedure raises an exception based on the value of an input +-- parameter. +-- +-- Add a public child function to the foundation package. This +-- function raises an exception based on the value of an input +-- parameter. +-- +-- In the main program, "with" the child packages, then check that +-- the exceptions are raised and handled as expected. Ensure that +-- exceptions are: +-- 1) raised in the public child package and handled/reraised to +-- be handled by the main program. +-- 2) raised and handled locally in the public child package. +-- 3) raised and handled locally by "others" in the public child +-- procedure. +-- 4) raised in the public child function and propagated to the +-- main program. +-- +-- TEST FILES: +-- The following files comprise this test: +-- +-- FA11D00.A +-- CA11D010.A +-- CA11D011.A +-- CA11D012.A +-- => CA11D013.AM +-- +-- +-- CHANGE HISTORY: +-- 06 Dec 94 SAIC ACVC 2.0 +-- +--! + +with FA11D00.CA11D010; -- Add_Subtract_Complex +with FA11D00.CA11D011; -- Multiply_Complex +with FA11D00.CA11D012; -- Divide_Complex + +with Report; + + +procedure CA11D013 is + + package Complex_Pkg renames FA11D00; + package Add_Subtract_Complex_Pkg renames FA11D00.CA11D010; + use Complex_Pkg; + +begin + + Report.Test ("CA11D013", "Check that a child unit can raise an " & + "exception that is declared in parent"); + + + Add_Complex_Subtest: + declare + First : Complex_Type := Complex (Int_Type (Report.Ident_Int (3)), + Int_Type (Report.Ident_Int (7))); + Second : Complex_Type := Complex (Int_Type (Report.Ident_Int (5)), + Int_Type (Report.Ident_Int (3))); + Add_Result : Complex_Type := Complex (Int_Type (Report.Ident_Int (8)), + Int_Type (Report.Ident_Int (10))); + Third : Complex_Type := Complex (Int_Type(Report.Ident_Int(-100)), + Int_Type (Report.Ident_Int (100))); + Complex_Num : Complex_Type := Zero; + + begin + Add_Subtract_Complex_Pkg.Add (First, Second, Complex_Num); + + if (Complex_Num /= Add_Result) then + Report.Failed ("Incorrect results from addition"); + end if; + + -- Error is raised in child package and exception + -- will be handled/reraised to caller. + + Add_Subtract_Complex_Pkg.Add (First, Third, Complex_Num); + + -- Error was not raised in child package. + Report.Failed ("Exception was not reraised in addition"); + + exception + when Add_Error => + if not TC_Handled_In_Child_Pkg_Proc then + Report.Failed ("Exception was not raised in addition"); + else + TC_Handled_In_Caller := true; -- Exception is reraised from + -- child package. + end if; + + when others => + Report.Failed ("Unexpected exception in addition subtest"); + TC_Handled_In_Caller := false; -- Improper exception handling + -- in caller. + + end Add_Complex_Subtest; + + + Subtract_Complex_Subtest: + declare + First : Complex_Type := Complex (Int_Type (Report.Ident_Int (3)), + Int_Type (Report.Ident_Int (6))); + Second : Complex_Type := Complex (Int_Type (Report.Ident_Int (5)), + Int_Type (Report.Ident_Int (7))); + Sub_Result : Complex_Type := Complex (Int_Type (Report.Ident_Int (2)), + Int_Type (Report.Ident_Int (1))); + Third : Complex_Type := Complex (Int_Type(Report.Ident_Int(-200)), + Int_Type (Report.Ident_Int (1))); + Complex_Num : Complex_Type; + + begin + Complex_Num := Add_Subtract_Complex_Pkg.Subtract (Second, First); + + if (Complex_Num /= Sub_Result) then + Report.Failed ("Incorrect results from subtraction"); + end if; + + -- Error is raised and exception will be handled in child package. + Complex_Num := Add_Subtract_Complex_Pkg.Subtract (Second, Third); + + exception + when Subtract_Error => + Report.Failed ("Exception raised in subtraction and " & + "propagated to caller"); + TC_Handled_In_Child_Pkg_Func := false; -- Improper exception handling + -- in caller. + + when others => + Report.Failed ("Unexpected exception in subtraction subtest"); + TC_Handled_In_Child_Pkg_Func := false; -- Improper exception handling + -- in caller. + + end Subtract_Complex_Subtest; + + + Multiply_Complex_Subtest: + declare + First : Complex_Type := Complex (Int_Type(Report.Ident_Int(3)), + Int_Type (Report.Ident_Int (4))); + Second : Complex_Type := Complex (Int_Type(Report.Ident_Int(5)), + Int_Type (Report.Ident_Int (3))); + Mult_Result : Complex_Type := Complex(Int_Type(Report.Ident_Int(15)), + Int_Type(Report.Ident_Int (12))); + Third : Complex_Type := Complex(Int_Type(Report.Ident_Int(10)), + Int_Type(Report.Ident_Int (-10))); + Complex_Num : Complex_Type; + + begin + CA11D011 (First, Second, Complex_Num); + + if (Complex_Num /= Mult_Result) then + Report.Failed ("Incorrect results from multiplication"); + end if; + + -- Error is raised and exception will be handled in child package. + CA11D011 (First, Third, Complex_Num); + + exception + when Multiply_Error => + Report.Failed ("Exception raised in multiplication and " & + "propagated to caller"); + TC_Handled_In_Child_Sub := false; -- Improper exception handling + -- in caller. + + when others => + Report.Failed ("Unexpected exception in multiplication subtest"); + TC_Handled_In_Child_Sub := false; -- Improper exception handling + -- in caller. + end Multiply_Complex_Subtest; + + + Divide_Complex_Subtest: + declare + First : Complex_Type := Complex (Int_Type (Report.Ident_Int(10)), + Int_Type (Report.Ident_Int (15))); + Second : Complex_Type := Complex (Int_Type(Report.Ident_Int(5)), + Int_Type (Report.Ident_Int (3))); + Div_Result : Complex_Type := Complex (Int_Type(Report.Ident_Int(2)), + Int_Type (Report.Ident_Int (5))); + Third : Complex_Type := Complex (Int_Type(Report.Ident_Int(-10)), + Int_Type (Report.Ident_Int (0))); + Complex_Num : Complex_Type := Zero; + + begin + Complex_Num := CA11D012 (First, Second); + + if (Complex_Num /= Div_Result) then + Report.Failed ("Incorrect results from division"); + end if; + + -- Error is raised in child package; exception will be + -- propagated to caller. + Complex_Num := CA11D012 (Second, Third); + + -- Error was not raised in child package. + Report.Failed ("Exception was not raised in division subtest "); + + exception + when Divide_Error => + TC_Propagated_To_Caller := true; -- Exception is propagated. + + when others => + Report.Failed ("Unexpected exception in division subtest"); + TC_Propagated_To_Caller := false; -- Improper exception handling + -- in caller. + end Divide_Complex_Subtest; + + + if not (TC_Handled_In_Caller and -- Check to see that all + TC_Handled_In_Child_Pkg_Proc and -- exceptions were handled in + TC_Handled_In_Child_Pkg_Func and -- the proper locations. + TC_Handled_In_Child_Sub and + TC_Propagated_To_Caller) + then + Report.Failed ("Exceptions handled in incorrect locations"); + end if; + + Report.Result; + +end CA11D013; diff --git a/gcc/testsuite/ada/acats/tests/ca/ca11d02.a b/gcc/testsuite/ada/acats/tests/ca/ca11d02.a new file mode 100644 index 000000000..7b4f48869 --- /dev/null +++ b/gcc/testsuite/ada/acats/tests/ca/ca11d02.a @@ -0,0 +1,393 @@ +-- CA11D02.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 exception declared in a package can be raised by a +-- child of a child package. Check that it can be renamed in the +-- child of the child package and raised with the correct effect. +-- +-- TEST DESCRIPTION: +-- Declare a package which defines complex number abstraction with +-- user-defined exceptions (foundation code). +-- +-- Add a public child package to the above package. Declare two +-- subprograms for the parent type. +-- +-- Add a public grandchild package to the foundation package. Declare +-- subprograms to raise exceptions. +-- +-- In the main program, "with" the grandchild package, then check that +-- the exceptions are raised and handled as expected. Ensure that +-- exceptions are: +-- 1) raised in the public grandchild package and handled/reraised to +-- be handled by the main program. +-- 2) raised and handled locally by the "others" handler in the +-- public grandchild package. +-- 3) raised in the public grandchild and propagated to the main +-- program. +-- +-- TEST FILES: +-- This test depends on the following foundation code: +-- +-- FA11D00.A +-- +-- +-- CHANGE HISTORY: +-- 06 Dec 94 SAIC ACVC 2.0 +-- +--! + +-- Child package of FA11D00. + +package FA11D00.CA11D02_0 is -- Basic_Complex + + function "+" (Left, Right : Complex_Type) + return Complex_Type; -- Add two complex numbers. + + function "*" (Left, Right : Complex_Type) + return Complex_Type; -- Multiply two complex numbers. + +end FA11D00.CA11D02_0; -- Basic_Complex + +--=======================================================================-- + +package body FA11D00.CA11D02_0 is -- Basic_Complex + + function "+" (Left, Right : Complex_Type) return Complex_Type is + begin + return ( (Left.Real + Right.Real, Left.Imag + Right.Imag) ); + end "+"; + -------------------------------------------------------------- + function "*" (Left, Right : Complex_Type) return Complex_Type is + begin + return ( Real => (Left.Real * Right.Real), + Imag => (Left.Imag * Right.Imag) ); + end "*"; + +end FA11D00.CA11D02_0; -- Basic_Complex + +--=======================================================================-- + +-- Child package of FA11D00.CA11D02_0. +-- Grandchild package of FA11D00. + +package FA11D00.CA11D02_0.CA11D02_1 is -- Array_Complex + + Inverse_Error : exception renames Divide_Error; -- Reference to exception + -- in grandparent package. + Array_Size : constant := 2; + + type Complex_Array_Type is + array (1 .. Array_Size) of Complex_Type; -- Reference to type + -- in parent package. + + function Multiply (Left : Complex_Array_Type; -- Multiply two complex + Right : Complex_Array_Type) -- arrays. + return Complex_Array_Type; + + function Add (Left, Right : Complex_Array_Type) -- Add two complex + return Complex_Array_Type; -- arrays. + + procedure Inverse (Right : in Complex_Array_Type; -- Invert a complex + Left : in out Complex_Array_Type); -- array. + +end FA11D00.CA11D02_0.CA11D02_1; -- Array_Complex + +--=======================================================================-- + +with Report; + + +package body FA11D00.CA11D02_0.CA11D02_1 is -- Array_Complex + + function Multiply (Left : Complex_Array_Type; + Right : Complex_Array_Type) + return Complex_Array_Type is + + -- This procedure will raise an exception depending on the input + -- parameter. The exception will be handled locally by the + -- "others" handler. + + Result : Complex_Array_Type := (others => Zero); + + subtype Vector_Size is Positive range Left'Range; + + begin + if Left = Result or else Right = Result then -- Do not multiply zero. + raise Multiply_Error; -- Refence to exception in + -- grandparent package. + Report.Failed ("Program control not transferred by raise"); + else + for I in Vector_Size loop + Result(I) := ( Left(I) * Right(I) ); -- Basic_Complex."*". + end loop; + end if; + return (Result); + + exception + when others => + Report.Comment ("Exception is handled by others in Multiplication"); + TC_Handled_In_Grandchild_Pkg_Func := true; + return (Zero, Zero); + + end Multiply; + -------------------------------------------------------------- + function Add (Left, Right : Complex_Array_Type) + return Complex_Array_Type is + + -- This function will raise an exception depending on the input + -- parameter. The exception will be propagated and handled + -- by the caller. + + Result : Complex_Array_Type := (others => Zero); + + subtype Vector_Size is Positive range Left'Range; + + begin + if Left = Result or Right = Result then -- Do not add zero. + raise Add_Error; -- Refence to exception in + -- grandparent package. + Report.Failed ("Program control not transferred by raise"); + else + for I in Vector_Size loop + Result(I) := ( Left(I) + Right(I) ); -- Basic_Complex."+". + end loop; + end if; + return (Result); + + end Add; + -------------------------------------------------------------- + procedure Inverse (Right : in Complex_Array_Type; + Left : in out Complex_Array_Type) is + + -- This function will raise an exception depending on the input + -- parameter. The exception will be handled/reraised to be + -- handled by the caller. + + Result : Complex_Array_Type := (others => Zero); + + Array_With_Zero : boolean := false; + + begin + for I in 1 .. Right'Length loop + if Right(I) = Zero then -- Check for zero. + Array_With_Zero := true; + end if; + end loop; + + If Array_With_Zero then + raise Inverse_Error; -- Do not inverse zero. + Report.Failed ("Program control not transferred by raise"); + else + for I in 1 .. Array_Size loop + Left(I).Real := - Right(I).Real; + Left(I).Imag := - Right(I).Imag; + end loop; + end if; + + exception + when Inverse_Error => + TC_Handled_In_Grandchild_Pkg_Proc := true; + Left := Result; + raise; -- Reraise the Inverse_Error exception in the subtest. + Report.Failed ("Exception not reraised in handler"); + + when others => + Report.Failed ("Unexpected exception in procedure Inverse"); + end Inverse; + +end FA11D00.CA11D02_0.CA11D02_1; -- Array_Complex + +--=======================================================================-- + +with FA11D00.CA11D02_0.CA11D02_1; -- Array_Complex, + -- implicitly with Basic_Complex. +with Report; + +procedure CA11D02 is + + package Complex_Pkg renames FA11D00; + package Array_Complex_Pkg renames FA11D00.CA11D02_0.CA11D02_1; + + use Complex_Pkg; + use Array_Complex_Pkg; + +begin + + Report.Test ("CA11D02", "Check that an exception declared in a package " & + "can be raised by a child of a child package"); + + Multiply_Complex_Subtest: + declare + Operand_1 : Complex_Array_Type + := ( Complex (Int_Type (Report.Ident_Int (3)), + Int_Type (Report.Ident_Int (5))), + Complex (Int_Type (Report.Ident_Int (2)), + Int_Type (Report.Ident_Int (8))) ); + Operand_2 : Complex_Array_Type + := ( Complex (Int_Type (Report.Ident_Int (1)), + Int_Type (Report.Ident_Int (2))), + Complex (Int_Type (Report.Ident_Int (3)), + Int_Type (Report.Ident_Int (6))) ); + Operand_3 : Complex_Array_Type := ( Zero, Zero); + Mul_Result : Complex_Array_Type + := ( Complex (Int_Type (Report.Ident_Int (3)), + Int_Type (Report.Ident_Int (10))), + Complex (Int_Type (Report.Ident_Int (6)), + Int_Type (Report.Ident_Int (48))) ); + Complex_No : Complex_Array_Type := (others => Zero); + + begin + If (Multiply (Operand_1, Operand_2) /= Mul_Result) then + Report.Failed ("Incorrect results from multiplication"); + end if; + + -- Error is raised and exception will be handled in grandchild package. + + Complex_No := Multiply (Operand_1, Operand_3); + + if Complex_No /= (Zero, Zero) then + Report.Failed ("Exception was not raised in multiplication"); + end if; + + exception + when Multiply_Error => + Report.Failed ("Exception raised in multiplication and " & + "propagated to caller"); + TC_Handled_In_Grandchild_Pkg_Func := false; + -- Improper exception handling in caller. + + when others => + Report.Failed ("Unexpected exception in multiplication"); + TC_Handled_In_Grandchild_Pkg_Func := false; + -- Improper exception handling in caller. + + end Multiply_Complex_Subtest; + + + Add_Complex_Subtest: + declare + Operand_1 : Complex_Array_Type + := ( Complex (Int_Type (Report.Ident_Int (2)), + Int_Type (Report.Ident_Int (7))), + Complex (Int_Type (Report.Ident_Int (5)), + Int_Type (Report.Ident_Int (8))) ); + Operand_2 : Complex_Array_Type + := ( Complex (Int_Type (Report.Ident_Int (4)), + Int_Type (Report.Ident_Int (1))), + Complex (Int_Type (Report.Ident_Int (2)), + Int_Type (Report.Ident_Int (3))) ); + Operand_3 : Complex_Array_Type := ( Zero, Zero); + Add_Result : Complex_Array_Type + := ( Complex (Int_Type (Report.Ident_Int (6)), + Int_Type (Report.Ident_Int (8))), + Complex (Int_Type (Report.Ident_Int (7)), + Int_Type (Report.Ident_Int (11))) ); + Complex_No : Complex_Array_Type := (others => Zero); + + begin + Complex_No := Add (Operand_1, Operand_2); + + If (Complex_No /= Add_Result) then + Report.Failed ("Incorrect results from addition"); + end if; + + -- Error is raised in grandchild package and exception + -- will be propagated to caller. + + Complex_No := Add (Operand_1, Operand_3); + + if Complex_No = Add_Result then + Report.Failed ("Exception was not raised in addition"); + end if; + + exception + when Add_Error => + TC_Propagated_To_Caller := true; -- Exception is propagated. + + when others => + Report.Failed ("Unexpected exception in addition subtest"); + TC_Propagated_To_Caller := false; -- Improper exception handling + -- in caller. + end Add_Complex_Subtest; + + Inverse_Complex_Subtest: + declare + Operand_1 : Complex_Array_Type + := ( Complex (Int_Type (Report.Ident_Int (1)), + Int_Type (Report.Ident_Int (5))), + Complex (Int_Type (Report.Ident_Int (3)), + Int_Type (Report.Ident_Int (11))) ); + Operand_3 : Complex_Array_Type + := ( Zero, Complex (Int_Type (Report.Ident_Int (3)), + Int_Type (Report.Ident_Int (6))) ); + Inv_Result : Complex_Array_Type + := ( Complex (Int_Type (Report.Ident_Int (-1)), + Int_Type (Report.Ident_Int (-5))), + Complex (Int_Type (Report.Ident_Int (-3)), + Int_Type (Report.Ident_Int (-11))) ); + Complex_No : Complex_Array_Type := (others => Zero); + + begin + Inverse (Operand_1, Complex_No); + + if (Complex_No /= Inv_Result) then + Report.Failed ("Incorrect results from inverse"); + end if; + + -- Error is raised in grandchild package and exception + -- will be handled/reraised to caller. + + Inverse (Operand_3, Complex_No); + + Report.Failed ("Exception was not handled in inverse"); + + exception + when Inverse_Error => + if not TC_Handled_In_Grandchild_Pkg_Proc then + Report.Failed ("Exception was not raised in inverse"); + else + TC_Handled_In_Caller := true; -- Exception is reraised from + -- child package. + end if; + + when others => + Report.Failed ("Unexpected exception in inverse"); + TC_Handled_In_Caller := false; + -- Improper exception handling in caller. + + end Inverse_Complex_Subtest; + + if not (TC_Handled_In_Caller and -- Check to see that all + TC_Handled_In_Grandchild_Pkg_Proc and -- exceptions were handled + TC_Handled_In_Grandchild_Pkg_Func and -- in proper location. + TC_Propagated_To_Caller) + then + Report.Failed ("Exceptions handled in incorrect locations"); + end if; + + Report.Result; + +end CA11D02; diff --git a/gcc/testsuite/ada/acats/tests/ca/ca11d03.a b/gcc/testsuite/ada/acats/tests/ca/ca11d03.a new file mode 100644 index 000000000..901b8d217 --- /dev/null +++ b/gcc/testsuite/ada/acats/tests/ca/ca11d03.a @@ -0,0 +1,174 @@ +-- CA11D03.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 exception declared in a package can be raised by a +-- client of a child of the package. Check that it can be renamed in +-- the client of the child of the package and raised with the correct +-- effect. +-- +-- TEST DESCRIPTION: +-- Declare a package which defines complex number abstraction with +-- user-defined exceptions (foundation code). +-- +-- Add a public child package to the above package. Declare two +-- subprograms for the parent type. +-- +-- In the main program, "with" the child package, then check that +-- an exception can be raised and handled as expected. +-- +-- TEST FILES: +-- This test depends on the following foundation code: +-- +-- FA11D00.A +-- +-- +-- CHANGE HISTORY: +-- 06 Dec 94 SAIC ACVC 2.0 +-- +--! + +-- Child package of FA11D00. +package FA11D00.CA11D03_0 is -- Basic_Complex + + function "+" (Left, Right : Complex_Type) + return Complex_Type; -- Add two complex numbers. + + function "*" (Left, Right : Complex_Type) + return Complex_Type; -- Multiply two complex numbers. + +end FA11D00.CA11D03_0; -- Basic_Complex + +--=======================================================================-- + +package body FA11D00.CA11D03_0 is -- Basic_Complex + + function "+" (Left, Right : Complex_Type) return Complex_Type is + begin + return ( (Left.Real + Right.Real, Left.Imag + Right.Imag) ); + end "+"; + -------------------------------------------------------------- + function "*" (Left, Right : Complex_Type) return Complex_Type is + begin + return ( Real => (Left.Real * Right.Real), + Imag => (Left.Imag * Right.Imag) ); + end "*"; + +end FA11D00.CA11D03_0; -- Basic_Complex + +--=======================================================================-- + +with FA11D00.CA11D03_0; -- Basic_Complex, + -- implicitly with Complex_Definition. +with Report; + +procedure CA11D03 is + + package Complex_Pkg renames FA11D00; -- Complex_Definition_Pkg + package Basic_Complex_Pkg renames FA11D00.CA11D03_0; -- Basic_Complex + + use Complex_Pkg; + use Basic_Complex_Pkg; + + TC_Handled_In_Subtest_1, + TC_Handled_In_Subtest_2 : boolean := false; + +begin + + Report.Test ("CA11D03", "Check that an exception declared in a package " & + "can be raised by a client of a child of the package"); + + Multiply_Complex_Subtest: + declare + Operand_1 : Complex_Type := Complex (Int_Type (Report.Ident_Int (3)), + Int_Type (Report.Ident_Int (2))); + -- Referenced to function in parent package. + Operand_2 : Complex_Type := Complex (Int_Type (Report.Ident_Int (10)), + Int_Type (Report.Ident_Int (8))); + Mul_Res : Complex_type := Complex (Int_Type (Report.Ident_Int (30)), + Int_Type (Report.Ident_Int (16))); + Complex_No : Complex_Type := Zero; -- Zero is declared in parent package. + begin + Complex_No := Operand_1 * Operand_2; -- Basic_Complex."*". + if Complex_No /= Mul_Res then + Report.Failed ("Incorrect results from multiplication"); + end if; + + -- Error is raised and exception will be handled. + if Complex_No = Mul_Res then + raise Multiply_Error; -- Reference to exception in + end if; -- parent package. + + exception + when Multiply_Error => + TC_Handled_In_Subtest_1 := true; + when others => + TC_Handled_In_Subtest_1 := false; -- Improper exception handling. + + end Multiply_Complex_Subtest; + + Add_Complex_Subtest: + declare + Error_In_Client : exception renames Add_Error; + -- Reference to exception in parent package. + Operand_1 : Complex_Type := Complex (Int_Type (Report.Ident_Int (2)), + Int_Type (Report.Ident_Int (7))); + Operand_2 : Complex_Type := Complex (Int_Type (Report.Ident_Int (-4)), + Int_Type (Report.Ident_Int (1))); + Add_Res : Complex_type := Complex (Int_Type (Report.Ident_Int (-2)), + Int_Type (Report.Ident_Int (8))); + Complex_No : Complex_Type := One; -- One is declared in parent + -- package. + begin + Complex_No := Operand_1 + Operand_2; -- Basic_Complex."+". + + if Complex_No /= Add_Res then + Report.Failed ("Incorrect results from multiplication"); + end if; + + -- Error is raised and exception will be handled. + if Complex_No = Add_Res then + raise Error_In_Client; + end if; + + exception + when Error_In_Client => + TC_Handled_In_Subtest_2 := true; + + when others => + TC_Handled_In_Subtest_2 := false; -- Improper exception handling. + + end Add_Complex_Subtest; + + if not (TC_Handled_In_Subtest_1 and -- Check to see that all + TC_Handled_In_Subtest_2) -- exceptions were handled + -- in the proper location. + then + Report.Failed ("Exceptions handled in incorrect locations"); + end if; + + Report.Result; + +end CA11D03; diff --git a/gcc/testsuite/ada/acats/tests/ca/ca13001.a b/gcc/testsuite/ada/acats/tests/ca/ca13001.a new file mode 100644 index 000000000..094bd7a88 --- /dev/null +++ b/gcc/testsuite/ada/acats/tests/ca/ca13001.a @@ -0,0 +1,370 @@ +-- CA13001.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 separate protected unit declared in a non-generic child +-- unit of a private parent have the same visibility into its parent, +-- its siblings, and packages on which its parent depends as is available +-- at the point of their declaration. +-- +-- TEST DESCRIPTION: +-- A scenario is created that demonstrates the potential of having all +-- members of one family to take out a transportation. The restriction +-- is depend on each member to determine who can get a car, a clunker, +-- or a bicycle. If no transportation is available, that member has to +-- walk. +-- +-- Declare a package with location for each family member. Declare +-- a public parent package. Declare a private child package. Declare a +-- public grandchild of this private package. Declare a protected unit +-- as a subunit in a public grandchild package. This subunit has +-- visibility into it's parent body ancestor and its sibling. +-- +-- Declare another public parent package. The body of this package has +-- visibility into its private sibling's descendants. +-- +-- In the main program, "with"s the parent package. Check that the +-- protected subunit performs as expected. +-- +-- +-- CHANGE HISTORY: +-- 06 Dec 94 SAIC ACVC 2.0 +-- 16 Nov 95 SAIC Update and repair for ACVC 2.0.1 +-- +--! + +package CA13001_0 is + + type Location is (School, Work, Beach, Home); + type Family is (Father, Mother, Teen); + Destination : array (Family) of Location; + + -- Other type definitions and procedure declarations in real application. + +end CA13001_0; + +-- No bodies required for CA13001_0. + + --==================================================================-- + +-- Public parent. + +package CA13001_1 is + + type Transportation is (Bicycle, Clunker, New_Car); + type Key_Type is private; + Walking : boolean := false; + + -- Other type definitions and procedure declarations in real application. + +private + type Key_Type + is range Transportation'pos(Bicycle) .. Transportation'pos(New_Car); + +end CA13001_1; + +-- No bodies required for CA13001_1. + + --==================================================================-- + +-- Private child. + +private package CA13001_1.CA13001_2 is + + type Transport is + record + In_Use : boolean := false; + end record; + Vehicles : array (Transportation) of Transport; + + -- Other type definitions and procedure declarations in real application. + +end CA13001_1.CA13001_2; + +-- No bodies required for CA13001_1.CA13001_2. + + --==================================================================-- + +-- Public grandchild of a private parent. + +package CA13001_1.CA13001_2.CA13001_3 is + + Flat_Tire : array (Transportation) of boolean := (others => false); + + -- Other type definitions and procedure declarations in real application. + +end CA13001_1.CA13001_2.CA13001_3; + +-- No bodies required for CA13001_1.CA13001_2.CA13001_3. + + --==================================================================-- + +-- Context clauses required for visibility needed by a separate subunit. + +with CA13001_0; +use CA13001_0; + +-- Public grandchild of a private parent. + +package CA13001_1.CA13001_2.CA13001_4 is + + type Transit is + record + Available : boolean := false; + end record; + type Keys_Array is array (Transportation) of Transit; + Fuel : array (Transportation) of boolean := (others => true); + + protected Family_Transportation is + + procedure Get_Vehicle (Who : in Family; + Key : out Key_Type); + procedure Return_Vehicle (Tr : in Transportation); + function TC_Verify (What : Transportation) return boolean; + + private + Keys : Keys_Array; + + end Family_Transportation; + +end CA13001_1.CA13001_2.CA13001_4; + + --==================================================================-- + +-- Context clause required for visibility needed by a separate subunit. + +with CA13001_1.CA13001_2.CA13001_3; -- Public sibling. + +package body CA13001_1.CA13001_2.CA13001_4 is + + protected body Family_Transportation is separate; + +end CA13001_1.CA13001_2.CA13001_4; + + --==================================================================-- + +separate (CA13001_1.CA13001_2.CA13001_4) +protected body Family_Transportation is + + procedure Get_Vehicle (Who : in Family; + Key : out Key_Type) is + begin + case Who is + when Father|Mother => + -- Drive new car to work + + -- Reference package with'ed by the subunit parent's body. + if Destination(Who) = Work then + + -- Reference type declared in the private parent of the subunit + -- parent's body. + -- Reference type declared in the visible part of the + -- subunit parent's body. + if not Vehicles(New_Car).In_Use and Fuel(New_Car) + + -- Reference type declared in the public sibling of the + -- subunit parent's body. + and not CA13001_1.CA13001_2.CA13001_3.Flat_Tire(New_Car) then + Vehicles(New_Car).In_Use := true; + + -- Reference type declared in the private part of the + -- protected subunit. + Keys(New_Car).Available := false; + Key := Transportation'pos(New_Car); + else + -- Reference type declared in the grandparent of the subunit + -- parent's body. + Walking := true; + end if; + + -- Drive clunker to other destinations. + else + if not Vehicles(Clunker).In_Use and Fuel(Clunker) and not + CA13001_1.CA13001_2.CA13001_3.Flat_Tire(Clunker) then + Vehicles(Clunker).In_Use := true; + Keys(Clunker).Available := false; + Key := Transportation'pos(Clunker); + else + Walking := true; + Key := Transportation'pos(Bicycle); + end if; + end if; + + -- Similar for Teen. + when Teen => + if not Vehicles(Clunker).In_Use and Fuel(Clunker) and not + CA13001_1.CA13001_2.CA13001_3.Flat_Tire(Clunker) then + Vehicles(Clunker).In_Use := true; + Keys(Clunker).Available := false; + Key := Transportation'pos(Clunker); + else + Walking := true; + Key := Transportation'pos(Bicycle); + end if; + end case; + + end Get_Vehicle; + + ---------------------------------------------------------------- + + -- Any family member can bring back the transportation with the key. + + procedure Return_Vehicle (Tr : in Transportation) is + begin + Vehicles(Tr).In_Use := false; + Keys(Tr).Available := true; + end Return_Vehicle; + + ---------------------------------------------------------------- + + function TC_Verify (What : Transportation) return boolean is + begin + return Keys(What).Available; + end TC_Verify; + +end Family_Transportation; + + --==================================================================-- + +with CA13001_0; +use CA13001_0; + +-- Public child. + +package CA13001_1.CA13001_5 is + + -- In a real application, tasks could be used to demonstrate + -- a family transportation scenario, i.e., each member of + -- a family can take a vehicle out concurrently, then return + -- them at the same time. For the purposes of the test, family + -- transportation happens sequentially. + + procedure Provide_Transportation (Who : in Family; + Get_Key : out Key_Type; + Get_Veh : out boolean); + procedure Return_Transportation (What : in Transportation; + Rt_Veh : out boolean); + +end CA13001_1.CA13001_5; + + --==================================================================-- + +with CA13001_1.CA13001_2.CA13001_4; -- Public grandchild of a private parent, + -- implicitly with CA13001_1.CA13001_2. +package body CA13001_1.CA13001_5 is + + package Transportation_Pkg renames CA13001_1.CA13001_2.CA13001_4; + use Transportation_Pkg; + + -- These two validation subprograms provide the capability to check the + -- components defined in the private packages from within the client + -- program. + + procedure Provide_Transportation (Who : in Family; + Get_Key : out Key_Type; + Get_Veh : out boolean) is + begin + -- Goto work, school, or to the beach. + Family_Transportation.Get_Vehicle (Who, Get_Key); + if not Family_Transportation.TC_Verify + (Transportation'Val(Get_Key)) then + Get_Veh := true; + else + Get_Veh := false; + end if; + + end Provide_Transportation; + + ---------------------------------------------------------------- + + procedure Return_Transportation (What : in Transportation; + Rt_Veh : out boolean) is + begin + Family_Transportation.Return_Vehicle (What); + if Family_Transportation.TC_Verify(What) and + not CA13001_1.CA13001_2.Vehicles(What).In_Use then + Rt_Veh := true; + else + Rt_Veh := false; + end if; + + end Return_Transportation; + +end CA13001_1.CA13001_5; + + --==================================================================-- + +with CA13001_0; +with CA13001_1.CA13001_5; -- Implicitly with parent, CA13001_1. +with Report; + +procedure CA13001 is + + Mommy : CA13001_0.Family := CA13001_0.Mother; + Daddy : CA13001_0.Family := CA13001_0.Father; + BG : CA13001_0.Family := CA13001_0.Teen; + BG_Clunker : CA13001_1.Transportation := CA13001_1.Clunker; + Get_Key : CA13001_1.Key_Type; + Get_Transit : boolean := false; + Return_Transit : boolean := false; + +begin + Report.Test ("CA13001", "Check that a protected subunit declared in " & + "a child unit of a private parent have the same visibility " & + "into its parent, its parent's siblings, and packages on " & + "which its parent depends"); + + -- Get transportation for mother to go to work. + CA13001_0.Destination(CA13001_0.Mother) := CA13001_0.Work; + CA13001_1.CA13001_5.Provide_Transportation (Mommy, Get_Key, Get_Transit); + if not Get_Transit then + Report.Failed ("Failed to get mother transportation"); + end if; + + -- Get transportation for teen to go to school. + CA13001_0.Destination(CA13001_0.Teen) := CA13001_0.School; + Get_Transit := false; + CA13001_1.CA13001_5.Provide_Transportation (BG, Get_Key, Get_Transit); + if not Get_Transit then + Report.Failed ("Failed to get teen transportation"); + end if; + + -- Get transportation for father to go to the beach. + CA13001_0.Destination(CA13001_0.Father) := CA13001_0.Beach; + Get_Transit := false; + CA13001_1.CA13001_5.Provide_Transportation (Daddy, Get_Key, Get_Transit); + if Get_Transit and not CA13001_1.Walking then + Report.Failed ("Failed to make daddy to walk to the beach"); + end if; + + -- Return the clunker. + CA13001_1.CA13001_5.Return_Transportation (BG_Clunker, Return_Transit); + if not Return_Transit then + Report.Failed ("Failed to get back the clunker"); + end if; + + Report.Result; + +end CA13001; diff --git a/gcc/testsuite/ada/acats/tests/ca/ca13002.a b/gcc/testsuite/ada/acats/tests/ca/ca13002.a new file mode 100644 index 000000000..e985174af --- /dev/null +++ b/gcc/testsuite/ada/acats/tests/ca/ca13002.a @@ -0,0 +1,259 @@ +-- CA13002.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 two library child units and/or subunits may have the same +-- simple names if they have distinct expanded names. +-- +-- TEST DESCRIPTION: +-- Declare a package that provides some primitive functionality (minimal +-- terminal driver operations in this case). Add child packages to +-- expand the functionality for different but related contexts (different +-- terminal kinds). Add child packages, or subunits, to the children to +-- provide the same high level operation for each of the different +-- contexts (terminals). Since the operations are the same, at the leaf +-- level they are likely to have the same names. +-- +-- The main program "with"s the child packages. Check that the +-- child units and subunits perform as expected. +-- +-- +-- CHANGE HISTORY: +-- 06 Dec 94 SAIC ACVC 2.0 +-- +--! + +-- Public parent. +package CA13002_0 is -- Terminal_Driver. + + type TC_Name is (First_Child, Second_Child, Third_Child, Fourth_Child); + type TC_Call_From is (First_Grandchild, Second_Grandchild, First_Subunit, + Second_Subunit); + type TC_Calls_Arr is array (TC_Name, TC_Call_From) of boolean; + TC_Calls : TC_Calls_Arr := (others => (others => false)); + + -- In real application, Send_Control_Sequence sends keystrokes from + -- the terminal, i.e., space, escape, etc. + procedure Send_Control_Sequence (Row : in TC_Name; + Col : in TC_Call_From); + +end CA13002_0; + + --==================================================================-- + +-- First child. +package CA13002_0.CA13002_1 is -- Terminal_Driver.VT100 + + -- Move cursor up, down, left, or right. + procedure Move_Cursor (Col : in TC_Call_From); + +end CA13002_0.CA13002_1; + + --==================================================================-- + +-- First grandchild. +procedure CA13002_0.CA13002_1.CA13002_5; -- Terminal_Driver.VT100.Cursor_Up + + --==================================================================-- + +-- Second child. +package CA13002_0.CA13002_2 is -- Terminal_Driver.IBM3270 + + procedure Move_Cursor (Col : in TC_Call_From); + +end CA13002_0.CA13002_2; + + --==================================================================-- + +-- Second grandchild. +procedure CA13002_0.CA13002_2.CA13002_5; -- Terminal_Driver.IBM3270.Cursor_Up + + --==================================================================-- + +-- Third child. +package CA13002_0.CA13002_3 is -- Terminal_Driver.DOS_ANSI + + procedure Move_Cursor (Col : in TC_Call_From); + + procedure CA13002_5; -- Terminal_Driver.DOS_ANSI.Cursor_Up + -- implementation will be as a + -- separate subunit. +end CA13002_0.CA13002_3; + + --==================================================================-- + +-- Fourth child. +package CA13002_0.CA13002_4 is -- Terminal_Driver.WYSE + + procedure Move_Cursor (Col : in TC_Call_From); + + procedure CA13002_5; -- Terminal_Driver.WYSE.Cursor_Up + -- implementation will be as a + -- separate subunit. + +end CA13002_0.CA13002_4; + + --==================================================================-- + +-- Terminal_Driver. +package body CA13002_0 is + + procedure Send_Control_Sequence (Row : in TC_Name; + Col : in TC_Call_From) is + begin + -- Reads a key and takes action. + TC_Calls (Row, Col) := true; + end Send_Control_Sequence; + +end CA13002_0; + + --==================================================================-- + +-- Terminal_Driver.VT100. +package body CA13002_0.CA13002_1 is + + procedure Move_Cursor (Col : in TC_Call_From) is + begin + Send_Control_Sequence (First_Child, Col); + end Move_Cursor; + +end CA13002_0.CA13002_1; + + --==================================================================-- + +-- Terminal_Driver.VT100.Cursor_Up. +procedure CA13002_0.CA13002_1.CA13002_5 is +begin + Move_Cursor (First_Grandchild); -- from Terminal_Driver.VT100. +end CA13002_0.CA13002_1.CA13002_5; + + --==================================================================-- + +-- Terminal_Driver.IBM3270. +package body CA13002_0.CA13002_2 is + + procedure Move_Cursor (Col : in TC_Call_From) is + begin + Send_Control_Sequence (Second_Child, Col); + end Move_Cursor; + +end CA13002_0.CA13002_2; + + --==================================================================-- + +-- Terminal_Driver.IBM3270.Cursor_Up. +procedure CA13002_0.CA13002_2.CA13002_5 is +begin + Move_Cursor (Second_Grandchild); -- from Terminal_Driver.IBM3270. +end CA13002_0.CA13002_2.CA13002_5; + + --==================================================================-- + +-- Terminal_Driver.DOS_ANSI. +package body CA13002_0.CA13002_3 is + + procedure Move_Cursor (Col : in TC_Call_From) is + begin + Send_Control_Sequence (Third_Child, Col); + end Move_Cursor; + + procedure CA13002_5 is separate; + +end CA13002_0.CA13002_3; + + --==================================================================-- + +-- Terminal_Driver.DOS_ANSI.Cursor_Up. +separate (CA13002_0.CA13002_3) +procedure CA13002_5 is +begin + Move_Cursor (First_Subunit); -- from Terminal_Driver.DOS_ANSI. +end CA13002_5; + + --==================================================================-- + +-- Terminal_Driver.WYSE. +package body CA13002_0.CA13002_4 is + + procedure Move_Cursor (Col : in TC_Call_From) is + begin + Send_Control_Sequence (Fourth_Child, Col); + end Move_Cursor; + + procedure CA13002_5 is separate; + +end CA13002_0.CA13002_4; + + --==================================================================-- + +-- Terminal_Driver.WYSE.Cursor_Up. +separate (CA13002_0.CA13002_4) +procedure CA13002_5 is +begin + Move_Cursor (Second_Subunit); -- from Terminal_Driver.WYSE. +end CA13002_5; + + --==================================================================-- + +with CA13002_0.CA13002_1.CA13002_5; -- Terminal_Driver.VT100.Cursor_Up, + -- implicitly with parent, CA13002_0. +with CA13002_0.CA13002_2.CA13002_5; -- Terminal_Driver.IBM3270.Cursor_Up. +with CA13002_0.CA13002_3; -- Terminal_Driver.DOS_ANSI. +with CA13002_0.CA13002_4; -- Terminal_Driver.WYSE. +with Report; +use CA13002_0; -- All primitive subprograms directly + -- visible. + +procedure CA13002 is + Expected_Calls : constant CA13002_0.TC_Calls_Arr + := ((true, false, false, false), + (false, true , false, false), + (false, false, true , false), + (false, false, false, true )); +begin + Report.Test ("CA13002", "Check that two library units and/or subunits " & + "may have the same simple names if they have distinct " & + "expanded names"); + + -- Note that the leaves all have the same name. + -- Call the first grandchild. + CA13002_0.CA13002_1.CA13002_5; + + -- Call the second grandchild. + CA13002_0.CA13002_2.CA13002_5; + + -- Call the first subunit. + CA13002_0.CA13002_3.CA13002_5; + + -- Call the second subunit. + CA13002_0.CA13002_4.CA13002_5; + + if TC_Calls /= Expected_Calls then + Report.Failed ("Wrong result"); + end if; + + Report.Result; + +end CA13002; diff --git a/gcc/testsuite/ada/acats/tests/ca/ca13003.a b/gcc/testsuite/ada/acats/tests/ca/ca13003.a new file mode 100644 index 000000000..607639efe --- /dev/null +++ b/gcc/testsuite/ada/acats/tests/ca/ca13003.a @@ -0,0 +1,256 @@ +-- CA13003.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 separate subunits which share an ancestor may have the +-- same name if they have different fully qualified names. Check +-- the case of separate subunits of separate subunits. +-- This test is a change in semantics from Ada 83 to Ada 9X. +-- +-- TEST DESCRIPTION: +-- Declare a package that provides file processing operations. Declare +-- one separate package to do the file processing, and another to do the +-- auditing. These packages contain similar functions declared in +-- separate subunits. Verify that the main program can call the +-- separate subunits with the same name. +-- +-- +-- CHANGE HISTORY: +-- 06 Dec 94 SAIC ACVC 2.0 +-- +--! + +-- Simulates a file processing application. The processing package opens +-- files, reads files, does file processing, and generates reports. +-- The auditing package opens files, read files, and generates reports. + +package CA13003_0 is + + type File_ID is range 1 .. 100; + subtype File_Name is string (1 .. 10); + + TC_Open_For_Process : boolean := false; + TC_Open_For_Audit : boolean := false; + TC_Report_From_Process : boolean := false; + TC_Report_From_Audit : boolean := false; + + type File_Rec is + record + Name : File_Name; + ID : File_ID; + end record; + + procedure Initialize_File_Rec (Name_In : in File_Name; + ID_In : in File_ID; + File_In : out File_Rec); + + ---------------------------------------------------------------------- + + package CA13003_1 is -- File processing + + procedure CA13003_3; -- Open files + function CA13003_4 (ID_In : File_ID; File_In : File_Rec) + return File_Name; -- Process files + package CA13003_5 is -- Generate report + procedure Generate_Report; + end CA13003_5; + + end CA13003_1; + + ---------------------------------------------------------------------- + + package CA13003_2 is -- File auditing + + procedure CA13003_3; -- Open files + function CA13003_4 (ID_In : File_ID; File_In : File_Rec) + return File_Name; -- Process files + package CA13003_5 is -- Generate report + procedure Generate_Report; + end CA13003_5; + + end CA13003_2; + +end CA13003_0; + + --==================================================================-- + +package body CA13003_0 is + + procedure Initialize_File_Rec (Name_In : in File_Name; + ID_In : in File_ID; + File_In : out File_Rec) is + -- Not a real initialization. Real application can use file + -- database to create the file record. + begin + File_In.Name := Name_In; + File_In.ID := ID_In; + end Initialize_File_Rec; + + package body CA13003_1 is separate; + package body CA13003_2 is separate; + +end CA13003_0; + + --==================================================================-- + +separate (CA13003_0) +package body CA13003_1 is + + procedure CA13003_3 is separate; -- Open files + function CA13003_4 (ID_In : File_ID; File_In : File_Rec) + return File_Name is separate; -- Process files + package body CA13003_5 is separate; -- Generate report + +end CA13003_1; + + --==================================================================-- + +separate (CA13003_0.CA13003_1) +procedure CA13003_3 is -- Open files +begin + -- In real file processing application, open file from database, setup + -- data structure, etc. + TC_Open_For_Process := true; +end CA13003_3; + + --==================================================================-- + +separate (CA13003_0.CA13003_1) +function CA13003_4 (ID_In : File_ID; -- Process files + File_In : File_Rec) return File_Name is +begin + -- In real file processing application, process files for more information. + return File_In.Name; +end CA13003_4; + + --==================================================================-- + +separate (CA13003_0.CA13003_1) +package body CA13003_5 is -- Generate report + procedure Generate_Report is + begin + -- In real file processing application, generate various report from the + -- file database. + TC_Report_From_Process := true; + end Generate_Report; + +end CA13003_5; + + --==================================================================-- + +separate (CA13003_0) +package body CA13003_2 is + + procedure CA13003_3 is separate; -- Open files + function CA13003_4 (ID_In : File_ID; File_In : File_Rec) + return File_Name is separate; -- Process files + package body CA13003_5 is separate; -- Generate report + +end CA13003_2; + + --==================================================================-- + +separate (CA13003_0.CA13003_2) +procedure CA13003_3 is -- Open files +begin + TC_Open_For_Audit := true; +end CA13003_3; + + --==================================================================-- + +separate (CA13003_0.CA13003_2) +function CA13003_4 (ID_In : File_ID; + File_In : File_Rec) return File_Name is +begin + return File_In.Name; +end CA13003_4; + + --==================================================================-- + +separate (CA13003_0.CA13003_2) +package body CA13003_5 is -- Generate report + procedure Generate_Report is + begin + TC_Report_From_Audit := true; + end Generate_Report; + +end CA13003_5; + + --==================================================================-- + +with CA13003_0; +with Report; + +procedure CA13003 is + First_File_Name : CA13003_0.File_Name := "Joe Smith "; + First_File_Id : CA13003_0.File_ID := 11; + Second_File_Name : CA13003_0.File_Name := "John Schep"; + Second_File_Id : CA13003_0.File_ID := 47; + Expected_Name : CA13003_0.File_Name := " "; + Student_File : CA13003_0.File_Rec; + + function Process_Input_Files (ID_In : CA13003_0.File_ID; + File_In : CA13003_0.File_Rec) return + CA13003_0.File_Name renames CA13003_0.CA13003_1.CA13003_4; + + function Process_Audit_Files (ID_In : CA13003_0.File_ID; + File_In : CA13003_0.File_Rec) return + CA13003_0.File_Name renames CA13003_0.CA13003_2.CA13003_4; +begin + Report.Test ("CA13003", "Check that separate subunits which share " & + "an ancestor may have the same name if they have " & + "different fully qualified names"); + + Student_File := (ID => First_File_Id, Name => First_File_Name); + + -- Note that all subunits have the same simple name. + -- Generate report from file processing. + CA13003_0.CA13003_1.CA13003_3; + Expected_Name := Process_Input_Files (First_File_Id, Student_File); + CA13003_0.CA13003_1.CA13003_5.Generate_Report; + + if not CA13003_0.TC_Open_For_Process or + not CA13003_0.TC_Report_From_Process or + Expected_Name /= First_File_Name then + Report.Failed ("Unexpected results in processing file"); + end if; + + CA13003_0.Initialize_File_Rec + (Second_File_Name, Second_File_Id, Student_File); + + -- Generate report from file auditing. + CA13003_0.CA13003_2.CA13003_3; + Expected_Name := Process_Audit_Files (Second_File_Id, Student_File); + CA13003_0.CA13003_2.CA13003_5.Generate_Report; + + if not CA13003_0.TC_Open_For_Audit or + not CA13003_0.TC_Report_From_Audit or + Expected_Name /= Second_File_Name then + Report.Failed ("Unexpected results in auditing file"); + end if; + + Report.Result; + +end CA13003; diff --git a/gcc/testsuite/ada/acats/tests/ca/ca13a01.a b/gcc/testsuite/ada/acats/tests/ca/ca13a01.a new file mode 100644 index 000000000..3963bc61f --- /dev/null +++ b/gcc/testsuite/ada/acats/tests/ca/ca13a01.a @@ -0,0 +1,320 @@ +-- CA13A01.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 subunits declared in non-generic child units of a public +-- parent have the same visibility into its parent, its siblings +-- (public and private), and packages on which its parent depends +-- as is available at the point of their declaration. +-- +-- TEST DESCRIPTION: +-- Declare an check system procedure as a subunit in a private child +-- package of the basic operation package (FA13A00.A). This procedure +-- has visibility into its parent ancestor and its private sibling. +-- +-- Declare an emergency procedure as a subunit in a public child package +-- of the basic operation package (FA13A00.A). This procedure has +-- visibility into its parent ancestor and its private sibling. +-- +-- Declare an express procedure as a subunit in a public child subprogram +-- of the basic operation package (FA13A00.A). This procedure has +-- visibility into its parent ancestor and its public sibling. +-- +-- In the main program, "with"s the child package and subprogram. Check +-- that subunits perform as expected. +-- +-- TEST FILES: +-- The following files comprise this test: +-- +-- FA13A00.A +-- CA13A01.A +-- +-- +-- CHANGE HISTORY: +-- 06 Dec 94 SAIC ACVC 2.0 +-- +--! + +-- Private child package of an elevator application. This package +-- provides maintenance operations. + +private package FA13A00_1.CA13A01_4 is -- Maintenance operation + + One_Floor : Floor_No := 1; -- Type declared in parent. + + procedure Check_System; + + -- other type definitions and procedure declarations in real application. + +end FA13A00_1.CA13A01_4; + + --==================================================================-- + +-- Context clauses required for visibility needed by separate subunit. + +with FA13A00_0; -- Building Manager + +with FA13A00_1.FA13A00_2; -- Floor Calculation (private) + +with FA13A00_1.FA13A00_3; -- Move Elevator + +use FA13A00_0; + +package body FA13A00_1.CA13A01_4 is + + procedure Check_System is separate; + +end FA13A00_1.CA13A01_4; + + --==================================================================-- + +separate (FA13A00_1.CA13A01_4) + +-- Subunit Check_System declared in Maintenance Operation. + +procedure Check_System is +begin + -- See if regular power is on. + + if Power /= V120 then -- Reference package with'ed by + TC_Operation := false; -- the subunit parent's body. + end if; + + -- Test elevator function. + + FA13A00_1.FA13A00_3.Move_Elevator -- Reference public sibling of + (Penthouse, Call_Waiting); -- the subunit parent's body. + + if not Call_Waiting (Penthouse) then -- Reference private part of the + TC_Operation := false; -- parent of the subunit package's + -- body. + end if; + + FA13A00_1.FA13A00_2.Down (One_Floor); -- Reference private sibling of + -- the subunit parent's body. + + if Current_Floor /= Floor'pred (Penthouse) then + TC_Operation := false; -- Reference type declared in the + end if; -- parent of the subunit parent's + -- body. + +end Check_System; + + --==================================================================-- + +-- Public child package of an elevator application. This package provides +-- an emergency operation. + +package FA13A00_1.CA13A01_5 is -- Emergency Operation + + -- Other type definitions in real application. + + procedure Emergency; + +private + type Bell_Type is (Inactive, Active); + +end FA13A00_1.CA13A01_5; + + --==================================================================-- + +-- Context clauses required for visibility needed by separate subunit. + +with FA13A00_0; -- Building Manager + +with FA13A00_1.FA13A00_3; -- Move Elevator + +with FA13A00_1.CA13A01_4; -- Maintenance Operation (private) + +use FA13A00_0; + +package body FA13A00_1.CA13A01_5 is + + procedure Emergency is separate; + +end FA13A00_1.CA13A01_5; + + --==================================================================-- + +separate (FA13A00_1.CA13A01_5) + +-- Subunit Emergency declared in Maintenance Operation. + +procedure Emergency is + Bell : Bell_Type; -- Reference type declared in the + -- subunit parent's body. + +begin + -- Calls maintenance operation. + + FA13A00_1.CA13A01_4.Check_System; -- Reference private sibling of the + -- subunit parent 's body. + + -- Clear all calls to the elevator. + + Clear_Calls (Call_Waiting); -- Reference subprogram declared + -- in the parent of the subunit + -- parent's body. + for I in Floor loop + if Call_Waiting (I) then -- Reference private part of the + TC_Operation := false; -- parent of the subunit parent's + end if; -- body. + end loop; + + -- Move elevator to the basement. + + FA13A00_1.FA13A00_3.Move_Elevator -- Reference public sibling of the + (Basement, Call_Waiting); -- subunit parent's body. + + if Current_Floor /= Basement then -- Reference type declared in the + TC_Operation := false; -- parent of the subunit parent's + end if; -- body. + + -- Shut off power. + + Power := Off; -- Reference package with'ed by + -- the subunit parent's body. + + -- Activate bell. + + Bell := Active; -- Reference type declared in the + -- subunit parent's body. + +end Emergency; + + --==================================================================-- + +-- Public child subprogram of an elevator application. This subprogram +-- provides an express operation. + +procedure FA13A00_1.CA13A01_6; + + --==================================================================-- + +-- Context clauses required for visibility needed by separate subunit. + +with FA13A00_0; -- Building Manager + +with FA13A00_1.FA13A00_2; -- Floor Calculation (private) + +with FA13A00_1.FA13A00_3; -- Move Elevator + +use FA13A00_0; + +procedure FA13A00_1.CA13A01_6 is -- Express Operation + + -- Other type definitions in real application. + + procedure GoTo_Penthouse is separate; + +begin + GoTo_Penthouse; + +end FA13A00_1.CA13A01_6; + + --==================================================================-- + +separate (FA13A00_1.CA13A01_6) + +-- Subunit GoTo_Penthouse declared in Express Operation. + +procedure GoTo_Penthouse is +begin + -- Go faster. + + Power := V240; -- Reference package with'ed by + -- the subunit parent's body. + + -- Call elevator. + + Call (Penthouse, Call_Waiting); -- Reference subprogram declared in + -- the parent of the subunit + -- parent's body. + + if not Call_Waiting (Penthouse) then -- Reference private part of the + TC_Operation := false; -- parent of the subunit parent's + end if; -- body. + + -- Move elevator to Penthouse. + + FA13A00_1.FA13A00_3.Move_Elevator -- Reference public sibling of the + (Penthouse, Call_Waiting); -- subunit parent's body. + + if Current_Floor /= Penthouse then -- Reference type declared in the + TC_Operation := false; -- parent of the subunit parent's + end if; -- body. + + -- Return slowly + + while Current_Floor /= Floor1 loop -- Reference type, subprogram + FA13A00_1.FA13A00_2.Down (1); -- declared in the parent of the + -- subunit parent's body. + end loop; + + if Current_Floor /= Floor1 then -- Reference type declared in + TC_Operation := false; -- the parent of the subunit + end if; -- parent's body. + + -- Back to normal. + + Power := V120; -- Reference package with'ed by + -- the subunit parent's body. + +end GoTo_Penthouse; + + --==================================================================-- + +with FA13A00_1.CA13A01_5; -- Emergency Operation + -- implicitly with Basic Elevator + -- Operations + +with FA13A00_1.CA13A01_6; -- Express Operation + +with Report; + +procedure CA13A01 is + +begin + + Report.Test ("CA13A01", "Check that subunits declared in non-generic " & + "child units of a public parent have the same visibility " & + "into its parent, its parent's siblings, and packages on " & + "which its parent depends"); + + -- Go to Penthouse. + + FA13A00_1.CA13A01_6; + + -- Call emergency operation. + + FA13A00_1.CA13A01_5.Emergency; + + if not FA13A00_1.TC_Operation then + Report.Failed ("Incorrect elevator operation"); + end if; + + Report.Result; + +end CA13A01; diff --git a/gcc/testsuite/ada/acats/tests/ca/ca13a02.a b/gcc/testsuite/ada/acats/tests/ca/ca13a02.a new file mode 100644 index 000000000..82d1b6ea5 --- /dev/null +++ b/gcc/testsuite/ada/acats/tests/ca/ca13a02.a @@ -0,0 +1,301 @@ +-- CA13A02.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 subunits declared in generic child units of a public +-- parent have the same visibility into its parent, its siblings +-- (public and private), and packages on which its parent depends +-- as is available at the point of their declaration. +-- +-- TEST DESCRIPTION: +-- Declare an outside elevator button operation as a subunit in a +-- generic child package of the basic operation package (FA13A00.A). +-- This procedure has visibility into its parent ancestor and its +-- private sibling. +-- +-- In the main program, instantiate the child package. Check that +-- subunits perform as expected. +-- +-- TEST FILES: +-- The following files comprise this test: +-- +-- FA13A00.A +-- CA13A02.A +-- +-- +-- CHANGE HISTORY: +-- 06 Dec 94 SAIC ACVC 2.0 +-- +--! + +-- Public generic child package of an elevator application. This package +-- provides outside elevator button operations. + +generic -- Instantiate once for each floor. + Our_Floor : in Floor; -- Reference type declared in parent. + +package FA13A00_1.CA13A02_4 is -- Outside Elevator Button Operations + + type Light is (Up, Down, Express, Off); + + type Direction is (Up, Down, Express); + + function Call_Elevator (D : Direction) return Light; + + -- other type definitions and procedure declarations in real application. + +end FA13A00_1.CA13A02_4; + + --==================================================================-- + +-- Context clauses required for visibility needed by separate subunit. + +with FA13A00_0; -- Building Manager + +with FA13A00_1.FA13A00_2; -- Floor Calculation (private) + +with FA13A00_1.FA13A00_3; -- Move Elevator + +use FA13A00_0; + +package body FA13A00_1.CA13A02_4 is + + function Call_Elevator (D : Direction) return Light is separate; + +end FA13A00_1.CA13A02_4; + + --==================================================================-- + +separate (FA13A00_1.CA13A02_4) + +-- Subunit Call_Elevator declared in Outside Elevator Button Operations. + +function Call_Elevator (D : Direction) return Light is + Elevator_Button : Light; + +begin + -- See if power is on. + + if Power = Off then -- Reference package with'ed by + Elevator_Button := Off; -- the subunit parent's body. + + else + case D is + when Express => + FA13A00_1.FA13A00_3.Move_Elevator -- Reference public sibling of + (Penthouse, Call_Waiting); -- the subunit parent's body. + + Elevator_Button := Express; + + when Up => + if Current_Floor < Our_Floor then + FA13A00_1.FA13A00_2.Up -- Reference private sibling of + (Floor'pos (Our_Floor) -- the subunit parent's body. + - Floor'pos (Current_Floor)); + else + FA13A00_1.FA13A00_2.Down -- Reference private sibling of + (Floor'pos (Current_Floor) -- the subunit parent's body. + - Floor'pos (Our_Floor)); + end if; + + -- Call elevator. + + Call + (Current_Floor, Call_Waiting); -- Reference subprogram declared + -- in the parent of the subunit + -- parent's body. + Elevator_Button := Up; + + when Down => + if Current_Floor > Our_Floor then + FA13A00_1.FA13A00_2.Down -- Reference private sibling of + (Floor'pos (Current_Floor) -- the subunit parent's body. + - Floor'pos (Our_Floor)); + else + FA13A00_1.FA13A00_2.Up -- Reference private sibling of + (Floor'pos (Our_Floor) -- the subunit parent's body. + - Floor'pos (Current_Floor)); + end if; + + Elevator_Button := Down; + + -- Call elevator. + + Call + (Current_Floor, Call_Waiting); -- Reference subprogram declared + -- in the parent of the subunit + -- parent's body. + end case; + + if not Call_Waiting (Current_Floor) -- Reference private part of the + then -- parent of the subunit parent's + -- body. + TC_Operation := false; + end if; + + end if; + + return Elevator_Button; + +end Call_Elevator; + + --==================================================================-- + +with FA13A00_1.CA13A02_4; -- Outside Elevator Button Operations + -- implicitly with Basic Elevator + -- Operations +with Report; + +procedure CA13A02 is + +begin + + Report.Test ("CA13A02", "Check that subunits declared in generic child " & + "units of a public parent have the same visibility into " & + "its parent, its parent's siblings, and packages on " & + "which its parent depends"); + +-- Going from floor one to penthouse. + + Going_To_Penthouse: + declare + -- Declare instance of the child generic elevator package for penthouse. + + package Call_Elevator_Pkg is new FA13A00_1.CA13A02_4 + (FA13A00_1.Penthouse); + + use Call_Elevator_Pkg; + + Call_Button_Light : Light; + + begin + + Call_Button_Light := Call_Elevator (Express); + + if not FA13A00_1.TC_Operation or Call_Button_Light /= Express then + Report.Failed ("Incorrect elevator operation going to penthouse"); + end if; + + end Going_To_Penthouse; + +-- Going from penthouse to basement. + + Going_To_Basement: + declare + -- Declare instance of the child generic elevator package for basement. + + package Call_Elevator_Pkg is new FA13A00_1.CA13A02_4 + (FA13A00_1.Basement); + + use Call_Elevator_Pkg; + + Call_Button_Light : Light; + + begin + + Call_Button_Light := Call_Elevator (Down); + + if not FA13A00_1.TC_Operation or Call_Button_Light /= Down then + Report.Failed ("Incorrect elevator operation going to basement"); + end if; + + end Going_To_Basement; + +-- Going from basement to floor three. + + Going_To_Floor3: + declare + -- Declare instance of the child generic elevator package for floor + -- three. + + package Call_Elevator_Pkg is new FA13A00_1.CA13A02_4 + (FA13A00_1.Floor3); + + use Call_Elevator_Pkg; + + Call_Button_Light : Light; + + begin + + Call_Button_Light := Call_Elevator (Up); + + if not FA13A00_1.TC_Operation or Call_Button_Light /= Up then + Report.Failed ("Incorrect elevator operation going to floor 3"); + end if; + + end Going_To_Floor3; + +-- Going from floor three to floor two. + + Going_To_Floor2: + declare + -- Declare instance of the child generic elevator package for floor two. + + package Call_Elevator_Pkg is new FA13A00_1.CA13A02_4 + (FA13A00_1.Floor2); + + use Call_Elevator_Pkg; + + Call_Button_Light : Light; + + begin + + Call_Button_Light := Call_Elevator (Up); + + if not FA13A00_1.TC_Operation or Call_Button_Light /= Up then + Report.Failed ("Incorrect elevator operation going to floor 2"); + end if; + + end Going_To_Floor2; + +-- Going to floor one. + + Going_To_Floor1: + declare + -- Declare instance of the child generic elevator package for floor one. + + package Call_Elevator_Pkg is new FA13A00_1.CA13A02_4 + (FA13A00_1.Floor1); + + use Call_Elevator_Pkg; + + Call_Button_Light : Light; + + begin + -- Calling elevator from floor one. + + FA13A00_1.Current_Floor := FA13A00_1.Floor1; + + Call_Button_Light := Call_Elevator (Down); + + if not FA13A00_1.TC_Operation or Call_Button_Light /= Down then + Report.Failed ("Incorrect elevator operation going to floor 1"); + end if; + + end Going_To_Floor1; + + Report.Result; + +end CA13A02; diff --git a/gcc/testsuite/ada/acats/tests/ca/ca140230.a b/gcc/testsuite/ada/acats/tests/ca/ca140230.a new file mode 100644 index 000000000..95b72b1ab --- /dev/null +++ b/gcc/testsuite/ada/acats/tests/ca/ca140230.a @@ -0,0 +1,62 @@ +-- CA140230.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: +-- See CA140232.AM. +-- +-- TEST DESCRIPTION: +-- See CA140232.AM. +-- +-- TEST FILES: +-- This test consists of the following files: +-- -> CA140230.A +-- CA140231.A +-- CA140232.AM +-- CA140233.A +-- +-- PASS/FAIL CRITERIA: +-- See CA140232.AM. +-- +-- CHANGE HISTORY: +-- 07 DEC 96 SAIC ACVC 2.1: Initial version. +-- 13 SEP 99 RLB Changed to C-test (by AI-00077). +-- 20 MAR 00 RLB Removed special requirements, because there +-- aren't any. +-- +--! + +package CA14023_0 is + subtype Little_float is float digits 4 range 0.0..100.0; + type Data_rec is tagged record + Data : Little_float; + end record; +end CA14023_0; + +-------------------------------------------------------- + +generic + type Data_type is digits <>; + Floor : Data_type; +function CA14023_1 (P1, P2 : Data_type) return Data_type; diff --git a/gcc/testsuite/ada/acats/tests/ca/ca140231.a b/gcc/testsuite/ada/acats/tests/ca/ca140231.a new file mode 100644 index 000000000..32504b590 --- /dev/null +++ b/gcc/testsuite/ada/acats/tests/ca/ca140231.a @@ -0,0 +1,59 @@ +-- CA140231.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: +-- See CA140232.AM. +-- +-- TEST DESCRIPTION: +-- See CA140232.AM. +-- +-- TEST FILES: +-- This test consists of the following files: +-- CA140230.A +-- -> CA140231.A +-- CA140232.AM +-- CA140233.A +-- +-- PASS/FAIL CRITERIA: +-- See CA140232.AM. +-- +-- CHANGE HISTORY: +-- 07 DEC 96 SAIC ACVC 2.1: Initial version. +-- 13 SEP 99 RLB Changed to C-test (by AI-00077). +-- 20 MAR 00 RLB Removed special requirements, because there +-- aren't any. +-- +--! + +function CA14023_1 (P1, P2 : Data_type) return Data_type is +begin + if Floor > P1 and Floor > P2 then + return Floor; + elsif P2 > P1 then + return P2; + else + return P1; + end if; +end CA14023_1; diff --git a/gcc/testsuite/ada/acats/tests/ca/ca140232.am b/gcc/testsuite/ada/acats/tests/ca/ca140232.am new file mode 100644 index 000000000..d9ffba28f --- /dev/null +++ b/gcc/testsuite/ada/acats/tests/ca/ca140232.am @@ -0,0 +1,139 @@ +-- CA140232.AM +-- +-- Grant of Unlimited Rights +-- +-- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687, +-- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained +-- unlimited rights in the software and documentation contained herein. +-- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making +-- this public release, the Government intends to confer upon all +-- recipients unlimited rights equal to those held by the Government. +-- These rights include rights to use, duplicate, release or disclose the +-- released technical data and computer software in whole or in part, in +-- any manner and for any purpose whatsoever, and to have or permit others +-- to do so. +-- +-- DISCLAIMER +-- +-- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR +-- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED +-- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF 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 compilation unit may not depend semantically +-- on two different versions of the same compilation unit. +-- Check the case where a generic instantiation depends on +-- a generic function that is changed. +-- +-- TEST DESCRIPTION: +-- This test compiles a generic function, a generic +-- instantiation of the generic function, and a main +-- procedure that withs the instantiated generic +-- function. Then, a new version of the first generic +-- function is compiled (in a separate file, simulating +-- editing and modification to the unit). The test should +-- link the correct version of the withed function and +-- report "PASSED" at execution time. +-- +-- Note that compilers are required by the standard to support +-- replacement of a generic body without recompilation of the +-- instantation. The ARG confirmed 10.1.4(10) with AI-00077. +-- +-- To build this test: +-- 1) Compile the file CA140230 (and include the results in the +-- program library). +-- 2) Compile the file CA140231 (and include the results in the +-- program library). +-- 3) Compile the file CA140232 (and include the results in the +-- program library). +-- 4) Compile the file CA140233 (and include the results in the +-- program library). +-- 5) Build and run an executable image. +-- +-- TEST FILES: +-- This test consists of the following files: +-- CA140230.A +-- CA140231.A +-- -> CA140232.AM +-- CA140233.A +-- +-- CHANGE HISTORY: +-- 01 MAY 95 ACVC 1.12 LA5008T baseline version +-- 29 JUN 95 SAIC Initial version +-- 05 MAR 96 SAIC First revision after review +-- 18 NOV 96 SAIC Modified unit names and prologue to conform +-- to coding conventions. +-- 07 DEC 96 SAIC Moved CA14023_1 to a separate file. +-- 13 SEP 99 RLB Changed to C-test (by AI-00077). +-- 20 MAR 00 RLB Removed special requirements, because there +-- aren't any. +-- +--! + +with CA14023_0; +use CA14023_0; + +generic + Min : Little_float := 0.0; + type Any_rec is new Data_rec with private; +function CA14023_2 (R1, R2 : Any_rec) return Little_float; + +-------------------------------------------------------- + +with CA14023_1; + +function CA14023_2 (R1, R2 : Any_rec) return Little_float is + function Max_val is new CA14023_1 (Little_float, Min); +begin + return max_val (R1.Data, R2.Data); +end CA14023_2; + +-------------------------------------------------------- + +package CA14023_0.CA14023_3 is + type New_data_rec is new Data_rec with record + Other_val : integer := 100; + end record; +end CA14023_0.CA14023_3; + +-------------------------------------------------------- + +with Report; use Report; +with CA14023_2; +with CA14023_0; +with CA14023_0.CA14023_3; + +procedure CA140232 is + + NDR1, NDR2 : CA14023_0.CA14023_3.New_data_rec; + Min_value : constant CA14023_0.Little_float := 0.0; + TC_result : CA14023_0.Little_float; + function Max_Data_Val is new CA14023_2 (Min_value, + CA14023_0.CA14023_3.New_data_rec); +begin + Test ("CA14023", "Check that a compilation unit may not " & + "depend semantically on two different " & + "versions of the same compilation unit. " & + "Check the case where a generic " & + "instantiation depends on a generic " & + "function that is changed"); + + NDR1.Data := 2.0; + NDR2.Data := 5.0; + + TC_result := Max_Data_Val (NDR1, NDR2); + + if TC_result = 5.0 then + Failed ("Revised generic not used"); + elsif TC_result /= 0.0 then -- the minimum, floor + Failed ("Incorrect value returned"); -- value of 0.0 should + end if; -- be returned rather + -- than the min of the + -- two actual parameters + + Result; +end CA140232; diff --git a/gcc/testsuite/ada/acats/tests/ca/ca140233.a b/gcc/testsuite/ada/acats/tests/ca/ca140233.a new file mode 100644 index 000000000..a5334379d --- /dev/null +++ b/gcc/testsuite/ada/acats/tests/ca/ca140233.a @@ -0,0 +1,68 @@ +-- CA140233.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: +-- See CA140232.AM. +-- +-- TEST DESCRIPTION: +-- See CA140232.AM. +-- +-- TEST FILES: +-- This test consists of the following files: +-- CA140230.A +-- CA140231.A +-- CA140232.AM +-- -> CA140233.A +-- +-- PASS/FAIL CRITERIA: +-- See CA140232.AM. +-- +-- CHANGE HISTORY: +-- 01 MAY 95 ACVC 1.12 LA5008T baseline version +-- 29 JUN 95 SAIC Initial version +-- 05 MAR 96 SAIC First revision after review +-- 18 NOV 96 SAIC Modified unit names and prologue to conform +-- to coding conventions. +-- 07 DEC 96 SAIC Modified prologue to reflect new test +-- file organization. +-- 13 SEP 99 RLB Changed to C-test (by AI-00077). +-- 20 MAR 00 RLB Removed special requirements, because there +-- aren't any. +--! + +-- here is the replacement body, correcting "errors" in +-- the original + +function CA14023_1 (P1, P2 : Data_type) return Data_type is +begin + -- return min rather than max + if Floor < P1 and Floor < P2 then + return Floor; + elsif P2 < P1 then + return P2; + else + return P1; + end if; +end CA14023_1; diff --git a/gcc/testsuite/ada/acats/tests/ca/ca140280.a b/gcc/testsuite/ada/acats/tests/ca/ca140280.a new file mode 100644 index 000000000..1ffe3cbbf --- /dev/null +++ b/gcc/testsuite/ada/acats/tests/ca/ca140280.a @@ -0,0 +1,77 @@ +-- CA140280.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: +-- See CA140283.AM. +-- +-- TEST DESCRIPTION +-- See CA140283.AM. +-- +-- TEST FILES: +-- This test consists of the following files: +-- -> CA140280.A +-- CA140281.A +-- CA140282.A +-- CA140283.AM +-- +-- CHANGE HISTORY: +-- JBG 05/28/85 CREATED ORGINAL TEST. +-- RDH 04/18/90 ADDED CASES WHERE SUBPROGRAM PARAMETER TYPES ARE +-- NOT THE SAME. +-- RLB 07/08/99 Reinstated withdrawn test; revised to Ada 95 format. + +GENERIC + C : INTEGER; +PROCEDURE GENPROC_CA14028 (X : OUT INTEGER); + +WITH REPORT; USE REPORT; +PRAGMA ELABORATE (REPORT); +PROCEDURE GENPROC_CA14028 (X : OUT INTEGER) IS +BEGIN + X := IDENT_INT(C); +END GENPROC_CA14028; + +GENERIC +FUNCTION GENFUNC_CA14028 RETURN INTEGER; + +FUNCTION GENFUNC_CA14028 RETURN INTEGER IS +BEGIN + RETURN 2; +END GENFUNC_CA14028; + +WITH GENPROC_CA14028; +PRAGMA ELABORATE (GENPROC_CA14028); +PROCEDURE CA14028_PROC1 IS NEW GENPROC_CA14028(1); + +WITH GENFUNC_CA14028; +PRAGMA ELABORATE (GENFUNC_CA14028); +FUNCTION CA14028_FUNC2 IS NEW GENFUNC_CA14028; + +WITH GENPROC_CA14028; +PRAGMA ELABORATE (GENPROC_CA14028); +PROCEDURE CA14028_PROC3 IS NEW GENPROC_CA14028(3); + +WITH GENFUNC_CA14028; +PRAGMA ELABORATE (GENFUNC_CA14028); +FUNCTION CA14028_FUNC3 IS NEW GENFUNC_CA14028; diff --git a/gcc/testsuite/ada/acats/tests/ca/ca140281.a b/gcc/testsuite/ada/acats/tests/ca/ca140281.a new file mode 100644 index 000000000..57360c9eb --- /dev/null +++ b/gcc/testsuite/ada/acats/tests/ca/ca140281.a @@ -0,0 +1,67 @@ +-- CA140281.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: +-- See CA140283.AM. +-- +-- TEST DESCRIPTION +-- See CA140283.AM. +-- +-- TEST FILES: +-- This test consists of the following files: +-- CA140280.A +-- -> CA140281.A +-- CA140282.A +-- CA140283.AM +-- +-- CHANGE HISTORY: +-- JBG 05/28/85 CREATED ORGINAL TEST. +-- RDH 04/18/90 ADDED CASES WHERE SUBPROGRAM PARAMETER TYPES ARE +-- NOT THE SAME. +-- RLB 07/08/99 Reinstated withdrawn test; revised to Ada 95 format. + +PROCEDURE CA14028_PROC1 (X : OUT INTEGER) IS +BEGIN + X := 3; +END CA14028_PROC1; + +WITH REPORT; USE REPORT; +PRAGMA ELABORATE (REPORT); +FUNCTION CA14028_FUNC2 RETURN INTEGER IS +BEGIN + RETURN IDENT_INT(4); +END CA14028_FUNC2; + +WITH REPORT; USE REPORT; +PRAGMA ELABORATE (REPORT); +PROCEDURE CA14028_PROC3 (X : OUT BOOLEAN; Y : OUT INTEGER) IS +BEGIN + X := FALSE; + Y := IDENT_INT(6); +END CA14028_PROC3; + +FUNCTION CA14028_FUNC3 RETURN BOOLEAN IS +BEGIN + RETURN FALSE; +END CA14028_FUNC3; diff --git a/gcc/testsuite/ada/acats/tests/ca/ca140282.a b/gcc/testsuite/ada/acats/tests/ca/ca140282.a new file mode 100644 index 000000000..437f01889 --- /dev/null +++ b/gcc/testsuite/ada/acats/tests/ca/ca140282.a @@ -0,0 +1,64 @@ +-- CA140282.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: +-- See CA140283.AM. +-- +-- TEST DESCRIPTION +-- See CA140283.AM. +-- +-- TEST FILES: +-- This test consists of the following files: +-- CA140280.A +-- CA140281.A +-- -> CA140282.A +-- CA140283.AM +-- +-- CHANGE HISTORY: +-- JBG 05/28/85 CREATED ORIGINAL TEST. +-- RDH 04/18/90 ADDED CASES WHERE SUBPROGRAM PARAMETER TYPES ARE +-- NOT THE SAME. +-- RLB 07/08/99 Reinstated withdrawn test; revised to Ada 95 format. + +WITH GENPROC_CA14028; +PRAGMA ELABORATE (GENPROC_CA14028); +PROCEDURE CA14028_PROC5 IS NEW GENPROC_CA14028 (5); + +WITH GENFUNC_CA14028; +PRAGMA ELABORATE (GENFUNC_CA14028); +FUNCTION CA14028_FUNC22 IS NEW GENFUNC_CA14028; + +WITH REPORT; USE REPORT; +PRAGMA ELABORATE (REPORT); +PROCEDURE CA14028_PROC3 (X : OUT INTEGER) IS +BEGIN + X := IDENT_INT(4); +END CA14028_PROC3; + +WITH REPORT; USE REPORT; +PRAGMA ELABORATE (REPORT); +FUNCTION CA14028_FUNC3 RETURN INTEGER IS +BEGIN + RETURN IDENT_INT(7); +END CA14028_FUNC3; diff --git a/gcc/testsuite/ada/acats/tests/ca/ca140283.am b/gcc/testsuite/ada/acats/tests/ca/ca140283.am new file mode 100644 index 000000000..9a74b8d70 --- /dev/null +++ b/gcc/testsuite/ada/acats/tests/ca/ca140283.am @@ -0,0 +1,91 @@ +-- CA140283.AM +-- +-- Grant of Unlimited Rights +-- +-- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687, +-- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained +-- unlimited rights in the software and documentation contained herein. +-- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making +-- this public release, the Government intends to confer upon all +-- recipients unlimited rights equal to those held by the Government. +-- These rights include rights to use, duplicate, release or disclose the +-- released technical data and computer software in whole or in part, in +-- any manner and for any purpose whatsoever, and to have or permit others +-- to do so. +-- +-- DISCLAIMER +-- +-- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR +-- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED +-- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF 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 subprogram body is compiled as a library unit +-- it is not interpreted as a completion for any previous library +-- subprogram created by generic instantiation, and it therefore +-- declares a new library subprogram. +-- +-- TEST DESCRIPTION +-- A generic function and procedure plus their instantiations are +-- created. Then, subprogram bodies which ought to replace the +-- instantiations are compiled. Following that, additional instantiations +-- are compiled. Finally the main subprogram is compiled. +-- +-- TEST FILES: +-- This test consists of the following files: +-- CA140280.A +-- CA140281.A +-- CA140282.A +-- -> CA140283.AM +-- +-- CHANGE HISTORY: +-- JBG 05/28/85 CREATED ORIGINAL TEST. +-- RDH 04/18/90 ADDED CASES WHERE SUBPROGRAM PARAMETER TYPES ARE +-- NOT THE SAME. +-- THS 09/24/90 REWORDED HEADER COMMENTS, ERROR MESSAGES, AND +-- CALL TO TEST. CALLED IDENT_INT CONSISTENTLY. +-- RLB 07/08/99 Reinstated withdrawn test; revised to Ada 95 format. + +WITH REPORT; USE REPORT; +WITH CA14028_PROC1, CA14028_FUNC2, CA14028_PROC5, CA14028_FUNC22, + CA14028_PROC3, CA14028_FUNC3; +PROCEDURE CA140283 IS + TEMP : INTEGER := 0; +BEGIN + TEST ("CA14028", "Check that library subprograms created by " & + "generic instantiation are replaced " & + "when new non-generic subprogram bodies are " & + "compiled"); + + CA14028_PROC1(TEMP); + IF TEMP /= IDENT_INT(3) THEN + FAILED ("CA14028_Proc1 instantiation not replaced"); + END IF; + + IF CA14028_FUNC2 /= IDENT_INT(4) THEN + FAILED ("CA14028_Func2 instantiation not replaced"); + END IF; + + CA14028_PROC5(TEMP); + IF TEMP /= IDENT_INT(5) THEN + FAILED ("New CA14028_Proc5 instantiation not correct"); + END IF; + + IF CA14028_FUNC22 /= IDENT_INT(2) THEN + FAILED ("New CA14028_Func22 instantiation not correct"); + END IF; + + CA14028_PROC3(TEMP); + IF TEMP /= IDENT_INT(4) THEN + FAILED ("CA14028_Proc3 not replaced by correct version"); + END IF; + + IF CA14028_FUNC3 /= IDENT_INT(7) THEN + FAILED ("CA14028_Func3 not replaced by correct version"); + END IF; + + RESULT; +END CA140283; diff --git a/gcc/testsuite/ada/acats/tests/ca/ca15003.a b/gcc/testsuite/ada/acats/tests/ca/ca15003.a new file mode 100644 index 000000000..08fe1516d --- /dev/null +++ b/gcc/testsuite/ada/acats/tests/ca/ca15003.a @@ -0,0 +1,161 @@ +-- CA15003.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 the requirements of 10.1.5(4) and the modified 10.1.5(5) +-- from Technical Corrigendum 1. (Originally discussed as AI95-00136.) +-- Specifically: +-- Check that program unit pragma for a generic package are accepted +-- when given at the beginning of the package specification. +-- Check that a program unit pragma can be given for a generic +-- instantiation by placing the pragma immediately after the instantation. +-- +-- TEST DESCRIPTION +-- This test checks the cases that are *not* forbidden by the RM, +-- and makes sure such legal cases actually work. +-- +-- CHANGE HISTORY: +-- 29 JUN 1999 RAD Initial Version +-- 08 JUL 1999 RLB Cleaned up and added to test suite. +-- 27 AUG 1999 RLB Repaired errors introduced by me. +-- +--! + +with System; +package CA15003A is + pragma Pure; + + type Big_Int is range -System.Max_Int .. System.Max_Int; + type Big_Positive is new Big_Int range 1..Big_Int'Last; +end CA15003A; + +generic + type Int is new Big_Int; +package CA15003A.Pure is + pragma Pure; + function F(X: access Int) return Int; +end CA15003A.Pure; + +with CA15003A.Pure; +package CA15003A.Pure_Instance is new CA15003A.Pure(Int => Big_Positive); + pragma Pure(CA15003A.Pure_Instance); + +package body CA15003A.Pure is + function F(X: access Int) return Int is + begin + X.all := X.all + 1; + return X.all; + end F; +end CA15003A.Pure; + +generic +package CA15003A.Pure.Preelaborate is + pragma Preelaborate; + One: Int := 1; + function F(X: access Int) return Int; +end CA15003A.Pure.Preelaborate; + +package body CA15003A.Pure.Preelaborate is + function F(X: access Int) return Int is + begin + X.all := X.all + One; + return X.all; + end F; +end CA15003A.Pure.Preelaborate; + +with CA15003A.Pure_Instance; +with CA15003A.Pure.Preelaborate; +package CA15003A.Pure_Preelaborate_Instance is + new CA15003A.Pure_Instance.Preelaborate; + pragma Preelaborate(CA15003A.Pure_Preelaborate_Instance); + +package CA15003A.Empty_Pure is + pragma Pure; + pragma Elaborate_Body; +end CA15003A.Empty_Pure; + +package body CA15003A.Empty_Pure is +end CA15003A.Empty_Pure; + +package CA15003A.Empty_Preelaborate is + pragma Preelaborate; + pragma Elaborate_Body; + One: Big_Int := 1; +end CA15003A.Empty_Preelaborate; + +package body CA15003A.Empty_Preelaborate is + function F(X: access Big_Int) return Big_Int is + begin + X.all := X.all + One; + return X.all; + end F; +end CA15003A.Empty_Preelaborate; + +package CA15003A.Empty_Elaborate_Body is + pragma Elaborate_Body; + Three: aliased Big_Positive := 1; + Two, Tres: Big_Positive'Base := 0; +end CA15003A.Empty_Elaborate_Body; + +with Report; use Report; pragma Elaborate_All(Report); +with CA15003A.Pure_Instance; +with CA15003A.Pure_Preelaborate_Instance; +use CA15003A; +package body CA15003A.Empty_Elaborate_Body is +begin + if Two /= Big_Positive'Base(Ident_Int(0)) then + Failed ("Two should be zero now"); + end if; + if Tres /= Big_Positive'Base(Ident_Int(0)) then + Failed ("Tres should be zero now"); + end if; + if Two /= Tres then + Failed ("Tres should be zero now"); + end if; + Two := Pure_Instance.F(Three'Access); + Tres := Pure_Preelaborate_Instance.F(Three'Access); + if Two /= Big_Positive(Ident_Int(2)) then + Failed ("Two should be 2 now"); + end if; + if Tres /= Big_Positive(Ident_Int(3)) then + Failed ("Tres should be 3 now"); + end if; +end CA15003A.Empty_Elaborate_Body; + +with Report; use Report; +with CA15003A.Empty_Pure; +with CA15003A.Empty_Preelaborate; +with CA15003A.Empty_Elaborate_Body; use CA15003A.Empty_Elaborate_Body; +use type CA15003A.Big_Positive'Base; +procedure CA15003 is +begin + Test("CA15003", "Placement of Program Unit Pragmas in Generic Packages"); + if Two /= 2 then + Failed ("Two should be 2 now"); + end if; + if Tres /= 3 then + Failed ("Tres should be 3 now"); + end if; + Result; +end CA15003; diff --git a/gcc/testsuite/ada/acats/tests/ca/ca200020.a b/gcc/testsuite/ada/acats/tests/ca/ca200020.a new file mode 100644 index 000000000..c9508f4cc --- /dev/null +++ b/gcc/testsuite/ada/acats/tests/ca/ca200020.a @@ -0,0 +1,70 @@ +-- CA200020.A +-- +-- Grant of Unlimited Rights +-- +-- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687 and +-- F08630-91-C-0015, the U.S. Government obtained unlimited rights in the +-- software and documentation contained herein. Unlimited rights are +-- defined in DFAR 252.227-7013(a)(19). By making this public release, +-- the Government intends to confer upon all recipients unlimited rights +-- equal to those held by the Government. These rights include rights to +-- use, duplicate, release or disclose the released technical data and +-- computer software in whole or in part, in any manner and for any purpose +-- whatsoever, and to have or permit others to do so. +-- +-- DISCLAIMER +-- +-- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR +-- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED +-- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF 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 partition can be created even if the environment contains +-- two units with the same name. (This is rule 10.2(19)). +-- +-- TEST DESCRIPTION: +-- Declare the a parent package (CA20002_0). Declare a child package +-- (CA20002_0.CA20002_1). Declare a subunit in the parent package body +-- (CA20002_1). Declare a main subprogram that does NOT include the +-- child package. Insure that this partition can be created. +-- +-- This test is intended to test the effects of program maintenance. +-- After the programmer receives an error from creating a partition +-- like that tested in test LA20001, the programmer may then repair +-- the partition by eliminating the reference of the child unit. The +-- partition should be able to be created. +-- +-- To build this test: +-- 1) Compile the file CA200020 (and include the results in the +-- program library). +-- 2) Compile the file CA200021 (and include the results in the +-- program library). +-- 3) Compile the file CA200022 (and include the results in the +-- program library). +-- 4) Build an executable image, and run it. +-- +-- TEST FILES: +-- This test consists of the following files: +-- -> CA200020.A +-- CA200021.A +-- CA200022.AM +-- +-- CHANGE HISTORY: +-- 27 Jan 99 RLB Initial test. +-- 20 Mar 00 RLB Removed special requirements, because there +-- aren't any. +--! + +package CA20002_0 is + procedure Do_a_Little (A : out Integer); + +end CA20002_0; + +package CA20002_0.CA20002_1 is + My_Global : Integer; +end CA20002_0.CA20002_1; + diff --git a/gcc/testsuite/ada/acats/tests/ca/ca200021.a b/gcc/testsuite/ada/acats/tests/ca/ca200021.a new file mode 100644 index 000000000..0c5de3825 --- /dev/null +++ b/gcc/testsuite/ada/acats/tests/ca/ca200021.a @@ -0,0 +1,66 @@ +-- CA200021.A +-- +-- Grant of Unlimited Rights +-- +-- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687 and +-- F08630-91-C-0015, the U.S. Government obtained unlimited rights in the +-- software and documentation contained herein. Unlimited rights are +-- defined in DFAR 252.227-7013(a)(19). By making this public release, +-- the Government intends to confer upon all recipients unlimited rights +-- equal to those held by the Government. These rights include rights to +-- use, duplicate, release or disclose the released technical data and +-- computer software in whole or in part, in any manner and for any purpose +-- whatsoever, and to have or permit others to do so. +-- +-- DISCLAIMER +-- +-- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR +-- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED +-- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF 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: +-- See CA200020.A. +-- +-- TEST DESCRIPTION: +-- See CA200020.A. +-- +-- TEST FILES: +-- This test consists of the following files: +-- CA200020.A +-- -> CA200021.A +-- CA200022.AM +-- +-- PASS/FAIL CRITERIA: +-- See CA200020.A. +-- +-- CHANGE HISTORY: +-- 27 JAN 99 RLB Initial version. +-- 20 MAR 00 RLB Removed special requirements, because there +-- aren't any. +-- +--! + +package body CA20002_0 is + + function CA20002_1 return Integer is separate; -- Has the same expanded name + -- as the child. + -- Note: An implementation may produce a warning about the child + -- unit at this point, but it must accept the subunit declaration. + + procedure Do_a_Little (A : out Integer) is + begin + A := CA20002_1; + end Do_a_Little; + +end CA20002_0; + +with Report; +separate (CA20002_0) +function CA20002_1 return Integer is +begin + return Report.Ident_Int(5); +end CA20002_1; diff --git a/gcc/testsuite/ada/acats/tests/ca/ca200022.am b/gcc/testsuite/ada/acats/tests/ca/ca200022.am new file mode 100644 index 000000000..1e9b773e0 --- /dev/null +++ b/gcc/testsuite/ada/acats/tests/ca/ca200022.am @@ -0,0 +1,64 @@ +-- CA200022.AM +-- +-- Grant of Unlimited Rights +-- +-- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687 and +-- F08630-91-C-0015, the U.S. Government obtained unlimited rights in the +-- software and documentation contained herein. Unlimited rights are +-- defined in DFAR 252.227-7013(a)(19). By making this public release, +-- the Government intends to confer upon all recipients unlimited rights +-- equal to those held by the Government. These rights include rights to +-- use, duplicate, release or disclose the released technical data and +-- computer software in whole or in part, in any manner and for any purpose +-- whatsoever, and to have or permit others to do so. +-- +-- DISCLAIMER +-- +-- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR +-- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED +-- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF 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: +-- See CA200020.A. +-- +-- TEST DESCRIPTION: +-- See CA200020.A. +-- +-- TEST FILES: +-- This test consists of the following files: +-- CA200020.A +-- CA200021.A +-- -> CA200022.AM +-- +-- PASS/FAIL CRITERIA: +-- See CA200020.A. +-- +-- CHANGE HISTORY: +-- 25 JAN 99 RLB Initial version. +-- 08 JUL 99 RLB Repaired comments. +-- 20 MAR 00 RLB Removed special requirements, because there +-- aren't any. +--! + +with Report; +use Report; +with CA20002_0; -- Child unit not included in the partition. +procedure CA200022 is + Value : Integer := 0; +begin + Test ("CA20002","Check that compiling multiple units with the same " & + "name does not prevent the creation of a partition " & + "using only one of the units."); + CA20002_0.Do_a_Little (Value); + if Report.Equal (Value, 5) then + null; -- OK. + else + Failed ("Wrong result from subunit"); + end if; + + Result; +end CA200022; diff --git a/gcc/testsuite/ada/acats/tests/ca/ca2001h0.ada b/gcc/testsuite/ada/acats/tests/ca/ca2001h0.ada new file mode 100644 index 000000000..f40744fbd --- /dev/null +++ b/gcc/testsuite/ada/acats/tests/ca/ca2001h0.ada @@ -0,0 +1,40 @@ +-- CA2001H0.ADA + +-- Grant of Unlimited Rights +-- +-- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687, +-- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained +-- unlimited rights in the software and documentation contained herein. +-- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making +-- this public release, the Government intends to confer upon all +-- recipients unlimited rights equal to those held by the Government. +-- These rights include rights to use, duplicate, release or disclose the +-- released technical data and computer software in whole or in part, in +-- any manner and for any purpose whatsoever, and to have or permit others +-- to do so. +-- +-- DISCLAIMER +-- +-- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR +-- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED +-- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE +-- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE +-- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A +-- PARTICULAR PURPOSE OF SAID MATERIAL. +--* +-- WKB 6/25/81 +-- JBG 8/25/83 + +FUNCTION CA2001H0 RETURN INTEGER IS + + PACKAGE CA2001H1 IS + I : INTEGER := 0; + END CA2001H1; + + PACKAGE BODY CA2001H1 IS SEPARATE; + +BEGIN + + RETURN CA2001H1.I; + +END CA2001H0; diff --git a/gcc/testsuite/ada/acats/tests/ca/ca2001h1.ada b/gcc/testsuite/ada/acats/tests/ca/ca2001h1.ada new file mode 100644 index 000000000..db0797d72 --- /dev/null +++ b/gcc/testsuite/ada/acats/tests/ca/ca2001h1.ada @@ -0,0 +1,39 @@ +-- CA2001H1.ADA + +-- Grant of Unlimited Rights +-- +-- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687, +-- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained +-- unlimited rights in the software and documentation contained herein. +-- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making +-- this public release, the Government intends to confer upon all +-- recipients unlimited rights equal to those held by the Government. +-- These rights include rights to use, duplicate, release or disclose the +-- released technical data and computer software in whole or in part, in +-- any manner and for any purpose whatsoever, and to have or permit others +-- to do so. +-- +-- DISCLAIMER +-- +-- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR +-- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED +-- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE +-- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE +-- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A +-- PARTICULAR PURPOSE OF SAID MATERIAL. +--* +-- WKB 6/25/81 +-- JBG 8/25/83 +-- BHS 7/31/84 + +SEPARATE (CA2001H0) + +PACKAGE BODY CA2001H1 IS + PROCEDURE NOT_USED IS SEPARATE; + +BEGIN + + I := 1; + NOT_USED; + +END CA2001H1; diff --git a/gcc/testsuite/ada/acats/tests/ca/ca2001h2.ada b/gcc/testsuite/ada/acats/tests/ca/ca2001h2.ada new file mode 100644 index 000000000..c6f672b15 --- /dev/null +++ b/gcc/testsuite/ada/acats/tests/ca/ca2001h2.ada @@ -0,0 +1,38 @@ +-- CA2001H2.ADA + +-- Grant of Unlimited Rights +-- +-- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687, +-- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained +-- unlimited rights in the software and documentation contained herein. +-- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making +-- this public release, the Government intends to confer upon all +-- recipients unlimited rights equal to those held by the Government. +-- These rights include rights to use, duplicate, release or disclose the +-- released technical data and computer software in whole or in part, in +-- any manner and for any purpose whatsoever, and to have or permit others +-- to do so. +-- +-- DISCLAIMER +-- +-- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR +-- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED +-- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE +-- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE +-- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A +-- PARTICULAR PURPOSE OF SAID MATERIAL. +--* +-- WKB 6/25/81 +-- JBG 8/25/83 + +FUNCTION CA2001H0 RETURN INTEGER IS + + PACKAGE CA2001H1 IS + I : INTEGER := 2; + END CA2001H1; + +BEGIN + + RETURN CA2001H1.I; + +END CA2001H0; diff --git a/gcc/testsuite/ada/acats/tests/ca/ca2001h3.ada b/gcc/testsuite/ada/acats/tests/ca/ca2001h3.ada new file mode 100644 index 000000000..9da25eea1 --- /dev/null +++ b/gcc/testsuite/ada/acats/tests/ca/ca2001h3.ada @@ -0,0 +1,66 @@ +-- CA2001H3M.ADA + +-- Grant of Unlimited Rights +-- +-- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687, +-- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained +-- unlimited rights in the software and documentation contained herein. +-- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making +-- this public release, the Government intends to confer upon all +-- recipients unlimited rights equal to those held by the Government. +-- These rights include rights to use, duplicate, release or disclose the +-- released technical data and computer software in whole or in part, in +-- any manner and for any purpose whatsoever, and to have or permit others +-- to do so. +-- +-- DISCLAIMER +-- +-- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR +-- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED +-- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE +-- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE +-- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A +-- PARTICULAR PURPOSE OF SAID MATERIAL. +--* +-- CHECK THAT IF A BODY_STUB IS DELETED FROM A COMPILATION UNIT, +-- THE PREVIOUSLY EXISTING SUBUNIT CAN NO LONGER BE ACCESSED. + +-- SEPARATE FILES ARE; +-- CA2001H0 A LIBRARY FUNCTION (CA2001H0). +-- CA2001H1 A SUBUNIT PACKAGE BODY. +-- CA2001H2 A LIBRARY FUNCTION (CA2001H0). +-- CA2001H3M THE MAIN PROCEDURE. + +-- WKB 6/25/81 +-- JRK 6/26/81 +-- SPS 11/2/82 +-- JBG 8/25/83 + + +WITH REPORT, CA2001H0; +USE REPORT; +PROCEDURE CA2001H3M IS + + I : INTEGER := -1; + +BEGIN + TEST ("CA2001H", "IF A BODY_STUB IS DELETED FROM A COMPILATION " & + "UNIT, THE PREVIOUSLY EXISTING SUBUNIT CAN NO " & + "LONGER BE ACCESSED"); + + I := CA2001H0; + + IF I = 1 THEN + FAILED ("SUBUNIT ACCESSED"); + END IF; + + IF I = 0 THEN + FAILED ("OLD LIBRARY UNIT ACCESSED"); + END IF; + + IF I /= 2 THEN + FAILED ("NEW LIBRARY UNIT NOT ACCESSED"); + END IF; + + RESULT; +END CA2001H3M; diff --git a/gcc/testsuite/ada/acats/tests/ca/ca2002a0.ada b/gcc/testsuite/ada/acats/tests/ca/ca2002a0.ada new file mode 100644 index 000000000..f48f58bd3 --- /dev/null +++ b/gcc/testsuite/ada/acats/tests/ca/ca2002a0.ada @@ -0,0 +1,139 @@ +-- CA2002A0M.ADA + +-- Grant of Unlimited Rights +-- +-- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687, +-- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained +-- unlimited rights in the software and documentation contained herein. +-- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making +-- this public release, the Government intends to confer upon all +-- recipients unlimited rights equal to those held by the Government. +-- These rights include rights to use, duplicate, release or disclose the +-- released technical data and computer software in whole or in part, in +-- any manner and for any purpose whatsoever, and to have or permit others +-- to do so. +-- +-- DISCLAIMER +-- +-- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR +-- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED +-- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF 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 SUBUNITS HAVING DIFFERENT ANCESTOR LIBRARY UNITS CAN HAVE +-- THE SAME NAME. + +-- SEPARATE FILES ARE: +-- CA2002A0M THE MAIN PROCEDURE, WITH SEPARATE LIBRARY +-- PACKAGES (CA2002A1) AND (CA2002A2). +-- CA2002A1 SUBUNIT BODIES FOR STUBS IN PACKAGE CA2002A1. +-- CA2002A2 SUBUNIT BODIES FOR STUBS IN PACKAGE CA2002A2. + +-- BHS 8/02/84 + +PACKAGE CA2002A1 IS + + PROCEDURE PROC (X : OUT INTEGER); + FUNCTION FUN RETURN BOOLEAN; + + PACKAGE PKG IS + I : INTEGER; + PROCEDURE PKG_PROC (XX : IN OUT INTEGER); + END PKG; + +END CA2002A1; + +PACKAGE BODY CA2002A1 IS + + PROCEDURE PROC (X : OUT INTEGER) IS SEPARATE; + FUNCTION FUN RETURN BOOLEAN IS SEPARATE; + PACKAGE BODY PKG IS SEPARATE; + +END CA2002A1; + + +PACKAGE CA2002A2 IS + + PROCEDURE PROC (Y : OUT INTEGER); + FUNCTION FUN (Z : INTEGER := 3) RETURN BOOLEAN; + + PACKAGE PKG IS + I : INTEGER; + PROCEDURE PKG_PROC (YY : IN OUT INTEGER); + END PKG; + +END CA2002A2; + +PACKAGE BODY CA2002A2 IS + + PROCEDURE PROC (Y : OUT INTEGER) IS SEPARATE; + FUNCTION FUN (Z : INTEGER := 3) RETURN BOOLEAN IS SEPARATE; + PACKAGE BODY PKG IS SEPARATE; + +END CA2002A2; + +WITH CA2002A1, CA2002A2; +WITH REPORT; USE REPORT; +PROCEDURE CA2002A0M IS +BEGIN + + TEST ("CA2002A", "SUBUNITS WITH DIFFERENT ANCESTORS " & + "CAN HAVE THE SAME NAME"); + + DECLARE + VAR1 : INTEGER; + USE CA2002A1; + BEGIN + + PROC (VAR1); + IF VAR1 /= 1 THEN + FAILED ("CA2002A1 PROCEDURE NOT INVOKED CORRECTLY"); + END IF; + + IF NOT FUN THEN + FAILED ("CA2002A1 FUNCTION NOT INVOKED CORRECTLY"); + END IF; + + IF PKG.I /= 1 THEN + FAILED ("CA2202A1 PKG VARIABLE NOT ACCESSED CORRECTLY"); + END IF; + + VAR1 := 5; + PKG.PKG_PROC (VAR1); + IF VAR1 /= 4 THEN + FAILED ("CA2002A1 PKG SUBUNIT NOT INVOKED CORRECTLY"); + END IF; + + END; + + DECLARE + VAR2 : INTEGER; + USE CA2002A2; + BEGIN + + PROC (VAR2); + IF VAR2 /= 2 THEN + FAILED ("CA2002A2 PROCEDURE NOT INVOKED CORRECTLY"); + END IF; + + IF FUN THEN + FAILED ("CA2002A2 FUNCTION NOT INVOKED CORRECTLY"); + END IF; + + IF PKG.I /= 2 THEN + FAILED ("CA2002A2 PKG VARIABLE NOT ACCESSED CORRECTLY"); + END IF; + + VAR2 := 3; + PKG.PKG_PROC (VAR2); + IF VAR2 /= 4 THEN + FAILED ("CA2002A2 PKG SUBUNIT NOT INVOKED CORRECTLY"); + END IF; + + END; + + RESULT; + +END CA2002A0M; diff --git a/gcc/testsuite/ada/acats/tests/ca/ca2002a1.ada b/gcc/testsuite/ada/acats/tests/ca/ca2002a1.ada new file mode 100644 index 000000000..064ec4d0f --- /dev/null +++ b/gcc/testsuite/ada/acats/tests/ca/ca2002a1.ada @@ -0,0 +1,53 @@ +-- CA2002A1.ADA + +-- Grant of Unlimited Rights +-- +-- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687, +-- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained +-- unlimited rights in the software and documentation contained herein. +-- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making +-- this public release, the Government intends to confer upon all +-- recipients unlimited rights equal to those held by the Government. +-- These rights include rights to use, duplicate, release or disclose the +-- released technical data and computer software in whole or in part, in +-- any manner and for any purpose whatsoever, and to have or permit others +-- to do so. +-- +-- DISCLAIMER +-- +-- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR +-- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED +-- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE +-- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE +-- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A +-- PARTICULAR PURPOSE OF SAID MATERIAL. +--* +-- SUBUNIT BODIES FOR STUBS GIVEN IN PACKAGE CA2002A1 IN FILE +-- CA2002A0M. + +-- BHS 8/02/84 + +SEPARATE (CA2002A1) +PROCEDURE PROC (X : OUT INTEGER) IS +BEGIN + X := 1; +END PROC; + +SEPARATE (CA2002A1) +FUNCTION FUN RETURN BOOLEAN IS +BEGIN + RETURN TRUE; +END FUN; + +SEPARATE (CA2002A1) +PACKAGE BODY PKG IS + PROCEDURE PKG_PROC (XX : IN OUT INTEGER) IS SEPARATE; +BEGIN + I := 1; +END PKG; + +SEPARATE (CA2002A1.PKG) +PROCEDURE PKG_PROC (XX : IN OUT INTEGER) IS +BEGIN + XX := XX - 1; +END PKG_PROC; diff --git a/gcc/testsuite/ada/acats/tests/ca/ca2002a2.ada b/gcc/testsuite/ada/acats/tests/ca/ca2002a2.ada new file mode 100644 index 000000000..6a1bc584c --- /dev/null +++ b/gcc/testsuite/ada/acats/tests/ca/ca2002a2.ada @@ -0,0 +1,53 @@ +-- CA2002A2.ADA + +-- Grant of Unlimited Rights +-- +-- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687, +-- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained +-- unlimited rights in the software and documentation contained herein. +-- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making +-- this public release, the Government intends to confer upon all +-- recipients unlimited rights equal to those held by the Government. +-- These rights include rights to use, duplicate, release or disclose the +-- released technical data and computer software in whole or in part, in +-- any manner and for any purpose whatsoever, and to have or permit others +-- to do so. +-- +-- DISCLAIMER +-- +-- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR +-- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED +-- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE +-- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE +-- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A +-- PARTICULAR PURPOSE OF SAID MATERIAL. +--* +-- SUBUNIT BODIES FOR STUBS GIVEN IN PACKAGE CA2002A2 IN FILE +-- CA2002A0M. + +-- BHS 8/02/84 + +SEPARATE (CA2002A2) +PROCEDURE PROC (Y : OUT INTEGER) IS +BEGIN + Y := 2; +END PROC; + +SEPARATE (CA2002A2) +FUNCTION FUN (Z : INTEGER := 3) RETURN BOOLEAN IS +BEGIN + RETURN Z /= 3; +END FUN; + +SEPARATE (CA2002A2) +PACKAGE BODY PKG IS + PROCEDURE PKG_PROC (YY : IN OUT INTEGER) IS SEPARATE; +BEGIN + I := 2; +END PKG; + +SEPARATE (CA2002A2.PKG) +PROCEDURE PKG_PROC (YY : IN OUT INTEGER) IS +BEGIN + YY := YY + 1; +END PKG_PROC; diff --git a/gcc/testsuite/ada/acats/tests/ca/ca2003a0.ada b/gcc/testsuite/ada/acats/tests/ca/ca2003a0.ada new file mode 100644 index 000000000..d6e47b46c --- /dev/null +++ b/gcc/testsuite/ada/acats/tests/ca/ca2003a0.ada @@ -0,0 +1,55 @@ +-- CA2003A0M.ADA + +-- Grant of Unlimited Rights +-- +-- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687, +-- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained +-- unlimited rights in the software and documentation contained herein. +-- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making +-- this public release, the Government intends to confer upon all +-- recipients unlimited rights equal to those held by the Government. +-- These rights include rights to use, duplicate, release or disclose the +-- released technical data and computer software in whole or in part, in +-- any manner and for any purpose whatsoever, and to have or permit others +-- to do so. +-- +-- DISCLAIMER +-- +-- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR +-- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED +-- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF 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 SUBUNIT HAS VISIBILITY OF IDENTIFIERS DECLARED +-- PRIOR TO ITS BODY_STUB. + +-- SEPARATE FILES ARE: +-- CA2003A0M THE MAIN PROCEDURE. +-- CA2003A1 A SUBUNIT PROCEDURE BODY. + +-- WKB 6/26/81 +-- JRK 6/26/81 + +WITH REPORT; +USE REPORT; +PROCEDURE CA2003A0M IS + + I : INTEGER := 1; + + PROCEDURE CA2003A1 IS SEPARATE; + + PACKAGE P IS + I : INTEGER := 2; + END P; + +BEGIN + TEST ("CA2003A", "A SUBUNIT HAS VISIBILITY OF IDENTIFIERS " & + "DECLARED BEFORE ITS BODY_STUB"); + + + CA2003A1; + + RESULT; +END CA2003A0M; diff --git a/gcc/testsuite/ada/acats/tests/ca/ca2003a1.ada b/gcc/testsuite/ada/acats/tests/ca/ca2003a1.ada new file mode 100644 index 000000000..ec09f13c8 --- /dev/null +++ b/gcc/testsuite/ada/acats/tests/ca/ca2003a1.ada @@ -0,0 +1,35 @@ +-- CA2003A1.ADA + +-- Grant of Unlimited Rights +-- +-- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687, +-- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained +-- unlimited rights in the software and documentation contained herein. +-- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making +-- this public release, the Government intends to confer upon all +-- recipients unlimited rights equal to those held by the Government. +-- These rights include rights to use, duplicate, release or disclose the +-- released technical data and computer software in whole or in part, in +-- any manner and for any purpose whatsoever, and to have or permit others +-- to do so. +-- +-- DISCLAIMER +-- +-- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR +-- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED +-- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE +-- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE +-- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A +-- PARTICULAR PURPOSE OF SAID MATERIAL. +--* +-- WKB 6/26/81 + +SEPARATE (CA2003A0M) +PROCEDURE CA2003A1 IS +BEGIN + + IF I /= 1 THEN + FAILED ("IDENTIFIER IN PARENT NOT VISIBLE"); + END IF; + +END CA2003A1; diff --git a/gcc/testsuite/ada/acats/tests/ca/ca2004a0.ada b/gcc/testsuite/ada/acats/tests/ca/ca2004a0.ada new file mode 100644 index 000000000..4eae5e241 --- /dev/null +++ b/gcc/testsuite/ada/acats/tests/ca/ca2004a0.ada @@ -0,0 +1,65 @@ +-- CA2004A0M.ADA + +-- Grant of Unlimited Rights +-- +-- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687, +-- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained +-- unlimited rights in the software and documentation contained herein. +-- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making +-- this public release, the Government intends to confer upon all +-- recipients unlimited rights equal to those held by the Government. +-- These rights include rights to use, duplicate, release or disclose the +-- released technical data and computer software in whole or in part, in +-- any manner and for any purpose whatsoever, and to have or permit others +-- to do so. +-- +-- DISCLAIMER +-- +-- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR +-- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED +-- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF 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 SUBUNIT HAS VISIBILITY OF IDENTIFIERS DECLARED +-- IN ANCESTORS OTHER THAN THE PARENT. + +-- SEPARATE FILES ARE: +-- CA2004A0M THE MAIN PROCEDURE. +-- CA2004A1 A SUBUNIT PACKAGE BODY. +-- CA2004A2 A SUBUNIT PROCEDURE BODY. +-- CA2004A3 A SUBUNIT PROCEDURE BODY. +-- CA2004A4 A SUBUNIT PROCEDURE BODY. + +-- WKB 6/26/81 +-- JRK 6/26/81 +-- BHS 7/31/84 + +WITH REPORT; +USE REPORT; +PROCEDURE CA2004A0M IS + + I : INTEGER := 1; + + PACKAGE CA2004A1 IS + J : INTEGER := 2; + PROCEDURE CA2004A2; + END CA2004A1; + + USE CA2004A1; + PACKAGE BODY CA2004A1 IS SEPARATE; + PROCEDURE CA2004A3 IS SEPARATE; + +BEGIN + TEST ("CA2004A", "CHECK THAT A SUBUNIT HAS VISIBILITY OF " & + "IDENTIFIERS DECLARED IN ANCESTORS"); + + + CA2004A1. + CA2004A2; + + CA2004A3; + + RESULT; +END CA2004A0M; diff --git a/gcc/testsuite/ada/acats/tests/ca/ca2004a1.ada b/gcc/testsuite/ada/acats/tests/ca/ca2004a1.ada new file mode 100644 index 000000000..2dcfd459f --- /dev/null +++ b/gcc/testsuite/ada/acats/tests/ca/ca2004a1.ada @@ -0,0 +1,34 @@ +-- CA2004A1.ADA + +-- Grant of Unlimited Rights +-- +-- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687, +-- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained +-- unlimited rights in the software and documentation contained herein. +-- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making +-- this public release, the Government intends to confer upon all +-- recipients unlimited rights equal to those held by the Government. +-- These rights include rights to use, duplicate, release or disclose the +-- released technical data and computer software in whole or in part, in +-- any manner and for any purpose whatsoever, and to have or permit others +-- to do so. +-- +-- DISCLAIMER +-- +-- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR +-- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED +-- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE +-- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE +-- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A +-- PARTICULAR PURPOSE OF SAID MATERIAL. +--* +-- WKB 6/26/81 + +SEPARATE (CA2004A0M) +PACKAGE BODY CA2004A1 IS + + K : INTEGER := 3; + + PROCEDURE CA2004A2 IS SEPARATE; + +END CA2004A1; diff --git a/gcc/testsuite/ada/acats/tests/ca/ca2004a2.ada b/gcc/testsuite/ada/acats/tests/ca/ca2004a2.ada new file mode 100644 index 000000000..739152fcd --- /dev/null +++ b/gcc/testsuite/ada/acats/tests/ca/ca2004a2.ada @@ -0,0 +1,43 @@ +-- CA2004A2.ADA + +-- Grant of Unlimited Rights +-- +-- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687, +-- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained +-- unlimited rights in the software and documentation contained herein. +-- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making +-- this public release, the Government intends to confer upon all +-- recipients unlimited rights equal to those held by the Government. +-- These rights include rights to use, duplicate, release or disclose the +-- released technical data and computer software in whole or in part, in +-- any manner and for any purpose whatsoever, and to have or permit others +-- to do so. +-- +-- DISCLAIMER +-- +-- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR +-- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED +-- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE +-- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE +-- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A +-- PARTICULAR PURPOSE OF SAID MATERIAL. +--* +-- WKB 6/26/81 + +SEPARATE (CA2004A0M.CA2004A1) +PROCEDURE CA2004A2 IS +BEGIN + + IF I /= 1 THEN + FAILED ("IDENTIFIER NOT VISIBLE - 1"); + END IF; + + IF J /= 2 THEN + FAILED ("IDENTIFIER NOT VISIBLE - 2"); + END IF; + + IF K /= 3 THEN + FAILED ("IDENTIFIER NOT VISIBLE - 3"); + END IF; + +END CA2004A2; diff --git a/gcc/testsuite/ada/acats/tests/ca/ca2004a3.ada b/gcc/testsuite/ada/acats/tests/ca/ca2004a3.ada new file mode 100644 index 000000000..528f4e2d5 --- /dev/null +++ b/gcc/testsuite/ada/acats/tests/ca/ca2004a3.ada @@ -0,0 +1,39 @@ +-- CA2004A3.ADA + +-- Grant of Unlimited Rights +-- +-- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687, +-- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained +-- unlimited rights in the software and documentation contained herein. +-- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making +-- this public release, the Government intends to confer upon all +-- recipients unlimited rights equal to those held by the Government. +-- These rights include rights to use, duplicate, release or disclose the +-- released technical data and computer software in whole or in part, in +-- any manner and for any purpose whatsoever, and to have or permit others +-- to do so. +-- +-- DISCLAIMER +-- +-- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR +-- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED +-- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE +-- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE +-- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A +-- PARTICULAR PURPOSE OF SAID MATERIAL. +--* +-- BHS 7/31/84 + +SEPARATE (CA2004A0M) +PROCEDURE CA2004A3 IS + + PROCEDURE CA2004A4 IS SEPARATE; + +BEGIN + + IF I /= IDENT_INT(1) OR + J /= IDENT_INT(2) THEN + FAILED ("IDENTIFIER NOT VISIBLE - 4"); + END IF; + +END CA2004A3; diff --git a/gcc/testsuite/ada/acats/tests/ca/ca2004a4.ada b/gcc/testsuite/ada/acats/tests/ca/ca2004a4.ada new file mode 100644 index 000000000..a71ca33f6 --- /dev/null +++ b/gcc/testsuite/ada/acats/tests/ca/ca2004a4.ada @@ -0,0 +1,36 @@ +-- CA2004A4.ADA + +-- Grant of Unlimited Rights +-- +-- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687, +-- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained +-- unlimited rights in the software and documentation contained herein. +-- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making +-- this public release, the Government intends to confer upon all +-- recipients unlimited rights equal to those held by the Government. +-- These rights include rights to use, duplicate, release or disclose the +-- released technical data and computer software in whole or in part, in +-- any manner and for any purpose whatsoever, and to have or permit others +-- to do so. +-- +-- DISCLAIMER +-- +-- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR +-- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED +-- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE +-- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE +-- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A +-- PARTICULAR PURPOSE OF SAID MATERIAL. +--* +-- BHS 7/31/84 + +SEPARATE (CA2004A0M.CA2004A3) +PROCEDURE CA2004A4 IS +BEGIN + + IF I /= IDENT_INT(1) OR + J /= IDENT_INT(2) THEN + FAILED ("IDENTIFIER NOT VISIBLE - 5"); + END IF; + +END CA2004A4; diff --git a/gcc/testsuite/ada/acats/tests/ca/ca2007a0.ada b/gcc/testsuite/ada/acats/tests/ca/ca2007a0.ada new file mode 100644 index 000000000..fb9e0b4ce --- /dev/null +++ b/gcc/testsuite/ada/acats/tests/ca/ca2007a0.ada @@ -0,0 +1,77 @@ +-- CA2007A0M.ADA + +-- Grant of Unlimited Rights +-- +-- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687, +-- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained +-- unlimited rights in the software and documentation contained herein. +-- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making +-- this public release, the Government intends to confer upon all +-- recipients unlimited rights equal to those held by the Government. +-- These rights include rights to use, duplicate, release or disclose the +-- released technical data and computer software in whole or in part, in +-- any manner and for any purpose whatsoever, and to have or permit others +-- to do so. +-- +-- DISCLAIMER +-- +-- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR +-- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED +-- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF 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 SUBUNIT PACKAGES ARE ELABORATED IN THE ORDER IN +-- WHICH THEIR BODY STUBS APPEAR, NOT (NECESSARILY) IN THE +-- ORDER IN WHICH THEY ARE COMPILED. + +-- SEPARATE FILES ARE: +-- CA2007A0M THE MAIN PROCEDURE. +-- CA2007A1 A SUBUNIT PACKAGE BODY. +-- CA2007A2 A SUBUNIT PACKAGE BODY. +-- CA2007A3 A SUBUNIT PACKAGE BODY. + +-- WKB 7/1/81 +-- JRK 7/1/81 + +WITH REPORT; +USE REPORT; +PROCEDURE CA2007A0M IS + + ELAB_ORDER : STRING (1..3) := " "; + NEXT : NATURAL := 1; + + PACKAGE CALL_TEST IS + END CALL_TEST; + + PACKAGE BODY CALL_TEST IS + BEGIN + TEST ("CA2007A", "CHECK THAT SUBUNIT PACKAGES ARE " & + "ELABORATED IN THE ORDER IN WHICH THEIR " & + "BODY STUBS APPEAR"); + END CALL_TEST; + + PACKAGE CA2007A3 IS + END CA2007A3; + + PACKAGE BODY CA2007A3 IS SEPARATE; + + PACKAGE CA2007A2 IS + END CA2007A2; + + PACKAGE BODY CA2007A2 IS SEPARATE; + + PACKAGE CA2007A1 IS + END CA2007A1; + + PACKAGE BODY CA2007A1 IS SEPARATE; + +BEGIN + + IF ELAB_ORDER /= "321" THEN + FAILED ("INCORRECT ELABORATION ORDER"); + END IF; + + RESULT; +END CA2007A0M; diff --git a/gcc/testsuite/ada/acats/tests/ca/ca2007a1.ada b/gcc/testsuite/ada/acats/tests/ca/ca2007a1.ada new file mode 100644 index 000000000..bef16f5ce --- /dev/null +++ b/gcc/testsuite/ada/acats/tests/ca/ca2007a1.ada @@ -0,0 +1,36 @@ +-- CA2007A1.ADA + +-- Grant of Unlimited Rights +-- +-- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687, +-- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained +-- unlimited rights in the software and documentation contained herein. +-- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making +-- this public release, the Government intends to confer upon all +-- recipients unlimited rights equal to those held by the Government. +-- These rights include rights to use, duplicate, release or disclose the +-- released technical data and computer software in whole or in part, in +-- any manner and for any purpose whatsoever, and to have or permit others +-- to do so. +-- +-- DISCLAIMER +-- +-- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR +-- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED +-- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE +-- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE +-- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A +-- PARTICULAR PURPOSE OF SAID MATERIAL. +--* +-- WKB 7/1/81 + +SEPARATE (CA2007A0M) + +PACKAGE BODY CA2007A1 IS + +BEGIN + + ELAB_ORDER (NEXT) := '1'; + NEXT := NEXT + 1; + +END CA2007A1; diff --git a/gcc/testsuite/ada/acats/tests/ca/ca2007a2.ada b/gcc/testsuite/ada/acats/tests/ca/ca2007a2.ada new file mode 100644 index 000000000..9429ea4dd --- /dev/null +++ b/gcc/testsuite/ada/acats/tests/ca/ca2007a2.ada @@ -0,0 +1,36 @@ +-- CA2007A2.ADA + +-- Grant of Unlimited Rights +-- +-- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687, +-- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained +-- unlimited rights in the software and documentation contained herein. +-- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making +-- this public release, the Government intends to confer upon all +-- recipients unlimited rights equal to those held by the Government. +-- These rights include rights to use, duplicate, release or disclose the +-- released technical data and computer software in whole or in part, in +-- any manner and for any purpose whatsoever, and to have or permit others +-- to do so. +-- +-- DISCLAIMER +-- +-- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR +-- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED +-- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE +-- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE +-- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A +-- PARTICULAR PURPOSE OF SAID MATERIAL. +--* +-- WKB 7/1/81 + +SEPARATE (CA2007A0M) + +PACKAGE BODY CA2007A2 IS + +BEGIN + + ELAB_ORDER (NEXT) := '2'; + NEXT := NEXT + 1; + +END CA2007A2; diff --git a/gcc/testsuite/ada/acats/tests/ca/ca2007a3.ada b/gcc/testsuite/ada/acats/tests/ca/ca2007a3.ada new file mode 100644 index 000000000..1d4886c6f --- /dev/null +++ b/gcc/testsuite/ada/acats/tests/ca/ca2007a3.ada @@ -0,0 +1,36 @@ +-- CA2007A3.ADA + +-- Grant of Unlimited Rights +-- +-- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687, +-- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained +-- unlimited rights in the software and documentation contained herein. +-- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making +-- this public release, the Government intends to confer upon all +-- recipients unlimited rights equal to those held by the Government. +-- These rights include rights to use, duplicate, release or disclose the +-- released technical data and computer software in whole or in part, in +-- any manner and for any purpose whatsoever, and to have or permit others +-- to do so. +-- +-- DISCLAIMER +-- +-- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR +-- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED +-- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE +-- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE +-- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A +-- PARTICULAR PURPOSE OF SAID MATERIAL. +--* +-- WKB 7/1/81 + +SEPARATE (CA2007A0M) + +PACKAGE BODY CA2007A3 IS + +BEGIN + + ELAB_ORDER (NEXT) := '3'; + NEXT := NEXT + 1; + +END CA2007A3; diff --git a/gcc/testsuite/ada/acats/tests/ca/ca2008a0.ada b/gcc/testsuite/ada/acats/tests/ca/ca2008a0.ada new file mode 100644 index 000000000..542591c52 --- /dev/null +++ b/gcc/testsuite/ada/acats/tests/ca/ca2008a0.ada @@ -0,0 +1,81 @@ +-- CA2008A0M.ADA + +-- Grant of Unlimited Rights +-- +-- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687, +-- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained +-- unlimited rights in the software and documentation contained herein. +-- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making +-- this public release, the Government intends to confer upon all +-- recipients unlimited rights equal to those held by the Government. +-- These rights include rights to use, duplicate, release or disclose the +-- released technical data and computer software in whole or in part, in +-- any manner and for any purpose whatsoever, and to have or permit others +-- to do so. +-- +-- DISCLAIMER +-- +-- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR +-- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED +-- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE +-- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE +-- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A +-- PARTICULAR PURPOSE OF SAID MATERIAL. +--* +-- CHECK THAT FOR AN OVERLOADED SUBPROGRAM, ONE OF THE +-- SUBPROGRAM BODIES CAN BE SPECIFIED WITH A BODY_STUB AND +-- COMPILED SEPARATELY. + +-- SEPARATE FILES ARE: +-- CA2008A0M THE MAIN PROCEDURE. +-- CA2008A1 A SUBUNIT PROCEDURE BODY. +-- CA2008A2 A SUBUNIT FUNCTION BODY. + +-- WKB 6/26/81 +-- SPS 11/2/82 + +WITH REPORT; +USE REPORT; +PROCEDURE CA2008A0M IS + + I : INTEGER := 0; + B : BOOLEAN := TRUE; + + PROCEDURE CA2008A1 (I : IN OUT INTEGER) IS + BEGIN + I := IDENT_INT (1); + END CA2008A1; + + PROCEDURE CA2008A1 (B : IN OUT BOOLEAN) IS SEPARATE; + + FUNCTION CA2008A2 RETURN INTEGER IS SEPARATE; + + FUNCTION CA2008A2 RETURN BOOLEAN IS + BEGIN + RETURN IDENT_BOOL (FALSE); + END CA2008A2; + +BEGIN + TEST ("CA2008A", "CHECK THAT AN OVERLOADED SUBPROGRAM " & + "CAN HAVE ONE OF ITS BODIES COMPILED SEPARATELY"); + + CA2008A1 (I); + IF I /= 1 THEN + FAILED ("OVERLOADED PROCEDURE NOT INVOKED - 1"); + END IF; + + CA2008A1 (B); + IF B THEN + FAILED ("OVERLOADED PROCEDURE NOT INVOKED - 2"); + END IF; + + IF CA2008A2 /= 2 THEN + FAILED ("OVERLOADED FUNCTION NOT INVOKED - 1"); + END IF; + + IF CA2008A2 THEN + FAILED ("OVERLOADED FUNCTION NOT INVOKED - 2"); + END IF; + + RESULT; +END CA2008A0M; diff --git a/gcc/testsuite/ada/acats/tests/ca/ca2008a1.ada b/gcc/testsuite/ada/acats/tests/ca/ca2008a1.ada new file mode 100644 index 000000000..7154a8d88 --- /dev/null +++ b/gcc/testsuite/ada/acats/tests/ca/ca2008a1.ada @@ -0,0 +1,35 @@ +-- CA2008A1.ADA + +-- Grant of Unlimited Rights +-- +-- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687, +-- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained +-- unlimited rights in the software and documentation contained herein. +-- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making +-- this public release, the Government intends to confer upon all +-- recipients unlimited rights equal to those held by the Government. +-- These rights include rights to use, duplicate, release or disclose the +-- released technical data and computer software in whole or in part, in +-- any manner and for any purpose whatsoever, and to have or permit others +-- to do so. +-- +-- DISCLAIMER +-- +-- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR +-- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED +-- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE +-- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE +-- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A +-- PARTICULAR PURPOSE OF SAID MATERIAL. +--* +-- WKB 6/26/81 + +SEPARATE (CA2008A0M) + +PROCEDURE CA2008A1 (B : IN OUT BOOLEAN) IS + +BEGIN + + B := FALSE; + +END CA2008A1; diff --git a/gcc/testsuite/ada/acats/tests/ca/ca2008a2.ada b/gcc/testsuite/ada/acats/tests/ca/ca2008a2.ada new file mode 100644 index 000000000..d8fd4399c --- /dev/null +++ b/gcc/testsuite/ada/acats/tests/ca/ca2008a2.ada @@ -0,0 +1,35 @@ +-- CA2008A2.ADA + +-- Grant of Unlimited Rights +-- +-- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687, +-- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained +-- unlimited rights in the software and documentation contained herein. +-- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making +-- this public release, the Government intends to confer upon all +-- recipients unlimited rights equal to those held by the Government. +-- These rights include rights to use, duplicate, release or disclose the +-- released technical data and computer software in whole or in part, in +-- any manner and for any purpose whatsoever, and to have or permit others +-- to do so. +-- +-- DISCLAIMER +-- +-- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR +-- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED +-- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE +-- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE +-- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A +-- PARTICULAR PURPOSE OF SAID MATERIAL. +--* +-- WKB 6/26/81 + +SEPARATE (CA2008A0M) + +FUNCTION CA2008A2 RETURN INTEGER IS + +BEGIN + + RETURN 2; + +END CA2008A2; diff --git a/gcc/testsuite/ada/acats/tests/ca/ca2009a.ada b/gcc/testsuite/ada/acats/tests/ca/ca2009a.ada new file mode 100644 index 000000000..4953045dc --- /dev/null +++ b/gcc/testsuite/ada/acats/tests/ca/ca2009a.ada @@ -0,0 +1,77 @@ +-- CA2009A.ADA + +-- Grant of Unlimited Rights +-- +-- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687, +-- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained +-- unlimited rights in the software and documentation contained herein. +-- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making +-- this public release, the Government intends to confer upon all +-- recipients unlimited rights equal to those held by the Government. +-- These rights include rights to use, duplicate, release or disclose the +-- released technical data and computer software in whole or in part, in +-- any manner and for any purpose whatsoever, and to have or permit others +-- to do so. +-- +-- DISCLAIMER +-- +-- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR +-- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED +-- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF 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 GENERIC PACKAGE SUBUNIT CAN BE SPECIFIED AND +-- INSTANTIATED. + +-- BHS 8/01/84 +-- JRK 5/24/85 CHANGED TO .ADA, SEE AI-00323. + + +WITH REPORT; +USE REPORT; +PROCEDURE CA2009A IS + + INT1 : INTEGER := 1; + + SUBTYPE STR15 IS STRING (1..15); + SVAR : STR15 := "ABCDEFGHIJKLMNO"; + + GENERIC + TYPE ITEM IS PRIVATE; + CON1 : IN ITEM; + VAR1 : IN OUT ITEM; + PACKAGE PKG1 IS + END PKG1; + + PACKAGE BODY PKG1 IS SEPARATE; + + PACKAGE NI_PKG1 IS NEW PKG1 (INTEGER, IDENT_INT(2), INT1); + PACKAGE NS_PKG1 IS NEW PKG1 (STR15, IDENT_STR("REINSTANTIATION"), + SVAR); + +BEGIN + + TEST ("CA2009A", "SPECIFICATION AND INSTANTIATION " & + "OF GENERIC PACKAGE SUBUNITS"); + + IF INT1 /= 2 THEN + FAILED ("INCORRECT INSTANTIATION - INTEGER"); + END IF; + + IF SVAR /= "REINSTANTIATION" THEN + FAILED ("INCORRECT INSTANTIATION - STRING"); + END IF; + + + RESULT; + +END CA2009A; + + +SEPARATE (CA2009A) +PACKAGE BODY PKG1 IS +BEGIN + VAR1 := CON1; +END PKG1; diff --git a/gcc/testsuite/ada/acats/tests/ca/ca2009c0.ada b/gcc/testsuite/ada/acats/tests/ca/ca2009c0.ada new file mode 100644 index 000000000..aedd31ba8 --- /dev/null +++ b/gcc/testsuite/ada/acats/tests/ca/ca2009c0.ada @@ -0,0 +1,83 @@ +-- CA2009C0M.ADA + +-- Grant of Unlimited Rights +-- +-- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687, +-- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained +-- unlimited rights in the software and documentation contained herein. +-- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making +-- this public release, the Government intends to confer upon all +-- recipients unlimited rights equal to those held by the Government. +-- These rights include rights to use, duplicate, release or disclose the +-- released technical data and computer software in whole or in part, in +-- any manner and for any purpose whatsoever, and to have or permit others +-- to do so. +-- +-- DISCLAIMER +-- +-- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR +-- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED +-- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF 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 PACKAGE SUBUNIT CAN BE SPECIFIED AND +-- INSTANTIATED. IN THIS TEST, THE SUBUNIT BODY IS IN A +-- SEPARATE FILE. + +-- APPLICABILITY CRITERIA: +-- THIS TEST MUST RUN AND REPORT "PASSED" FOR ALL ADA 95 IMPLEMENTATIONS. + +-- SEPARATE FILES ARE: +-- CA2009C0M THE MAIN PROCEDURE. +-- CA2009C1 A SUBUNIT PACKAGE BODY (PKG1). + +-- HISTORY: +-- BHS 08/01/84 CREATED ORIGINAL TEST. +-- BCB 01/05/88 MODIFIED HEADER. +-- EDS 08/04/98 REMOVE CONTROL Z AT END OF FILE. +-- RLB 09/13/99 UPDATED APPLICABILITY CRITERIA FOR ADA 95. +-- RLB 09/15/99 REMOVED JUNK COMMENT. + +WITH REPORT; +USE REPORT; +PROCEDURE CA2009C0M IS + + INT1 : INTEGER := 1; + + SUBTYPE STR15 IS STRING (1..15); + SVAR : STR15 := "ABCDEFGHIJKLMNO"; + + GENERIC + TYPE ITEM IS PRIVATE; + CON1 : IN ITEM; + VAR1 : IN OUT ITEM; + PACKAGE PKG1 IS + END PKG1; + + PACKAGE BODY PKG1 IS SEPARATE; + + PACKAGE NI_PKG1 IS NEW PKG1 (INTEGER, IDENT_INT(2), INT1); + PACKAGE NS_PKG1 IS NEW PKG1 (STR15, IDENT_STR("REINSTANTIATION"), + SVAR); + +BEGIN + + TEST ("CA2009C", "SPECIFICATION AND INSTANTIATION " & + "OF GENERIC PACKAGE SUBUNITS " & + " - SEPARATE FILES USED"); + + IF INT1 /= 2 THEN + FAILED ("INCORRECT INSTANTIATION - INTEGER"); + END IF; + + IF SVAR /= "REINSTANTIATION" THEN + FAILED ("INCORRECT INSTANTIATION - STRING"); + END IF; + + + RESULT; + +END CA2009C0M; diff --git a/gcc/testsuite/ada/acats/tests/ca/ca2009c1.ada b/gcc/testsuite/ada/acats/tests/ca/ca2009c1.ada new file mode 100644 index 000000000..6bf9a4bb6 --- /dev/null +++ b/gcc/testsuite/ada/acats/tests/ca/ca2009c1.ada @@ -0,0 +1,43 @@ +-- CA2009C1.ADA + +-- Grant of Unlimited Rights +-- +-- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687, +-- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained +-- unlimited rights in the software and documentation contained herein. +-- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making +-- this public release, the Government intends to confer upon all +-- recipients unlimited rights equal to those held by the Government. +-- These rights include rights to use, duplicate, release or disclose the +-- released technical data and computer software in whole or in part, in +-- any manner and for any purpose whatsoever, and to have or permit others +-- to do so. +-- +-- DISCLAIMER +-- +-- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR +-- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED +-- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE +-- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE +-- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A +-- PARTICULAR PURPOSE OF SAID MATERIAL. +--* +-- A GENERIC PACKAGE BODY. +-- THE DECLARATION AND AN INSTANTIATION ARE IN CA2009C0M.DEP. + +-- APPLICABILITY CRITERIA: +-- THIS UNIT MUST BE ACCEPTED BY ALL ADA 95 IMPLEMENTATIONS. + +-- HISTORY: +-- BHS 08/09/84 CREATED ORIGINAL TEST. +-- PWB 02/19/86 ADDED COMMENTS TO RELATE TO OTHER TEST FILES +-- AND TO DESCRIBE EXPECTED COMPILER ACTION. +-- BCB 01/05/88 MODIFIED HEADER. +-- EDS 08/04/98 REMOVE CONTROL Z AT END OF FILE. +-- RLB 09/13/99 UPDATED APPLICABILITY CRITERIA FOR ADA 95. + +SEPARATE (CA2009C0M) +PACKAGE BODY PKG1 IS +BEGIN + VAR1 := CON1; +END PKG1; diff --git a/gcc/testsuite/ada/acats/tests/ca/ca2009d.ada b/gcc/testsuite/ada/acats/tests/ca/ca2009d.ada new file mode 100644 index 000000000..65b5d8113 --- /dev/null +++ b/gcc/testsuite/ada/acats/tests/ca/ca2009d.ada @@ -0,0 +1,95 @@ +-- CA2009D.ADA + +-- Grant of Unlimited Rights +-- +-- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687, +-- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained +-- unlimited rights in the software and documentation contained herein. +-- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making +-- this public release, the Government intends to confer upon all +-- recipients unlimited rights equal to those held by the Government. +-- These rights include rights to use, duplicate, release or disclose the +-- released technical data and computer software in whole or in part, in +-- any manner and for any purpose whatsoever, and to have or permit others +-- to do so. +-- +-- DISCLAIMER +-- +-- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR +-- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED +-- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF 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 GENERIC SUBPROGRAM SUBUNIT CAN BE SPECIFIED AND +-- INSTANTIATED. + +-- BHS 8/01/84 +-- JRK 5/24/85 CHANGED TO .ADA, SEE AI-00323. + + +WITH REPORT; +USE REPORT; +PROCEDURE CA2009D IS + + INT1 : INTEGER := 1; + INT2 : INTEGER := 2; + + + GENERIC + TYPE ELEM IS PRIVATE; + PCON1 : IN ELEM; + PVAR1 : IN OUT ELEM; + PROCEDURE PROC1; + + + GENERIC + TYPE OBJ IS PRIVATE; + FCON1 : IN OBJ; + FVAR1 : IN OUT OBJ; + FUNCTION FUNC1 RETURN OBJ; + + + PROCEDURE PROC1 IS SEPARATE; + FUNCTION FUNC1 RETURN OBJ IS SEPARATE; + + + PROCEDURE NI_PROC1 IS NEW PROC1 (INTEGER, 2, INT1); + FUNCTION NI_FUNC1 IS NEW FUNC1 (INTEGER, 3, INT2); + + +BEGIN + + TEST ("CA2009D", "SPECIFICATION AND INSTANTIATION " & + "OF GENERIC SUBPROGRAM SUBUNITS"); + + NI_PROC1; + IF INT1 /= 2 THEN + FAILED ("INCORRECT INSTANTIATION - NI_PROC1"); + END IF; + + + IF NI_FUNC1 /= 3 THEN + FAILED ("INCORRECT INSTANTIATION - NI_FUNC1"); + END IF; + + + RESULT; + +END CA2009D; + + +SEPARATE (CA2009D) +PROCEDURE PROC1 IS +BEGIN + PVAR1 := PCON1; +END PROC1; + + +SEPARATE (CA2009D) +FUNCTION FUNC1 RETURN OBJ IS +BEGIN + FVAR1 := FCON1; + RETURN FVAR1; +END FUNC1; diff --git a/gcc/testsuite/ada/acats/tests/ca/ca2009f0.ada b/gcc/testsuite/ada/acats/tests/ca/ca2009f0.ada new file mode 100644 index 000000000..8bc23c11d --- /dev/null +++ b/gcc/testsuite/ada/acats/tests/ca/ca2009f0.ada @@ -0,0 +1,134 @@ +-- CA2009F0M.ADA + +-- Grant of Unlimited Rights +-- +-- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687, +-- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained +-- unlimited rights in the software and documentation contained herein. +-- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making +-- this public release, the Government intends to confer upon all +-- recipients unlimited rights equal to those held by the Government. +-- These rights include rights to use, duplicate, release or disclose the +-- released technical data and computer software in whole or in part, in +-- any manner and for any purpose whatsoever, and to have or permit others +-- to do so. +-- +-- DISCLAIMER +-- +-- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR +-- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED +-- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF 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 SUBPROGRAM SUBUNIT CAN BE SPECIFIED AND +-- INSTANTIATED. IN THIS TEST, SOME SUBUNIT BODIES ARE +-- IN SEPARATE FILES. + +-- APPLICABILITY CRITERIA: +-- THIS TEST MUST RUN AND REPORT "PASSED" FOR ALL ADA 95 IMPLEMENTATIONS. + +-- SEPARATE FILES ARE: +-- CA2009F0M THE MAIN PROCEDURE, WITH SUBUNIT BODIES FOR +-- PROC2 AND FUNC2. +-- CA2009F1 A SUBUNIT PROCEDURE BODY (PROC1). +-- CA2009F2 A SUBUNIT FUNCTION BODY (FUNC1). + +-- HISTORY: +-- BHS 08/01/84 CREATED ORIGINAL TEST. +-- PWB 02/19/86 ADDED "SOME" TO FIRST COMMENT. +-- BCB 01/05/88 MODIFIED HEADER. +-- EDS 08/04/98 REMOVE CONTROL Z AT END OF FILE. +-- RLB 09/13/99 UPDATED APPLICABILITY CRITERIA FOR ADA 95. +-- RLB 09/15/99 REMOVED JUNK COMMENT. + +WITH REPORT; +USE REPORT; +PROCEDURE CA2009F0M IS + + INT1 : INTEGER := 1; + INT2 : INTEGER := 2; + INT3 : INTEGER := 3; + INT4 : INTEGER := 4; + + + GENERIC + TYPE ELEM IS PRIVATE; + PCON1 : IN ELEM; + PVAR1 : IN OUT ELEM; + PROCEDURE PROC1; + + GENERIC + TYPE ELEM IS PRIVATE; + PCON2 : IN ELEM; + PVAR2 : IN OUT ELEM; + PROCEDURE PROC2; + + GENERIC + TYPE OBJ IS PRIVATE; + FCON1 : IN OBJ; + FVAR1 : IN OUT OBJ; + FUNCTION FUNC1 RETURN OBJ; + + GENERIC + TYPE OBJ IS PRIVATE; + FCON2 : IN OBJ; + FVAR2 : IN OUT OBJ; + FUNCTION FUNC2 RETURN OBJ; + + + PROCEDURE PROC1 IS SEPARATE; + PROCEDURE PROC2 IS SEPARATE; + FUNCTION FUNC1 RETURN OBJ IS SEPARATE; + FUNCTION FUNC2 RETURN OBJ IS SEPARATE; + + + PROCEDURE NI_PROC1 IS NEW PROC1 (INTEGER, 2, INT1); + PROCEDURE NI_PROC2 IS NEW PROC2 (INTEGER, 3, INT2); + FUNCTION NI_FUNC1 IS NEW FUNC1 (INTEGER, 4, INT3); + FUNCTION NI_FUNC2 IS NEW FUNC2 (INTEGER, 5, INT4); + + +BEGIN + + TEST ("CA2009F", "SPECIFICATION AND INSTANTIATION " & + "OF GENERIC SUBPROGRAM SUBUNITS"); + + NI_PROC1; + IF INT1 /= 2 THEN + FAILED ("INCORRECT INSTANTIATION - NI_PROC1"); + END IF; + + NI_PROC2; + IF INT2 /= 3 THEN + FAILED ("INCORRECT INSTANTIATION - NI_PROC2"); + END IF; + + IF NI_FUNC1 /= 4 THEN + FAILED ("INCORRECT INSTANTIATION - NI_FUNC1"); + END IF; + + IF NI_FUNC2 /= 5 THEN + FAILED ("INCORRECT INSTANTIATION - NI_FUNC2"); + END IF; + + + RESULT; + +END CA2009F0M; + + +SEPARATE (CA2009F0M) +PROCEDURE PROC2 IS +BEGIN + PVAR2 := PCON2; +END PROC2; + +SEPARATE (CA2009F0M) +FUNCTION FUNC2 RETURN OBJ IS +BEGIN + FVAR2 := FCON2; + RETURN FVAR2; +END FUNC2; diff --git a/gcc/testsuite/ada/acats/tests/ca/ca2009f1.ada b/gcc/testsuite/ada/acats/tests/ca/ca2009f1.ada new file mode 100644 index 000000000..e3e13cedb --- /dev/null +++ b/gcc/testsuite/ada/acats/tests/ca/ca2009f1.ada @@ -0,0 +1,43 @@ +-- CA2009F1.ADA + +-- Grant of Unlimited Rights +-- +-- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687, +-- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained +-- unlimited rights in the software and documentation contained herein. +-- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making +-- this public release, the Government intends to confer upon all +-- recipients unlimited rights equal to those held by the Government. +-- These rights include rights to use, duplicate, release or disclose the +-- released technical data and computer software in whole or in part, in +-- any manner and for any purpose whatsoever, and to have or permit others +-- to do so. +-- +-- DISCLAIMER +-- +-- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR +-- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED +-- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE +-- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE +-- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A +-- PARTICULAR PURPOSE OF SAID MATERIAL. +--* +-- SEPARATE GENERIC PROCEDURE BODY. +-- SPECIFICATION, BODY STUB, AND INSTANTIATION ARE IN A2009F0M.DEP. + +-- APPLICABILITY CRITERIA: +-- THIS UNIT MUST BE ACCEPTED BY ALL ADA 95 IMPLEMENTATIONS. + +-- HISTORY: +-- BHS 08/01/84 CREATED ORIGINAL TEST. +-- PWB 02/19/86 MODIFIED COMMENTS TO SHOW RELATION TO OTHER FILES +-- AND TO CLARIFY NON-APPLICABILITY. +-- BCB 01/05/88 MODIFIED HEADER. +-- EDS 08/04/98 REMOVE CONTROL Z AT END OF FILE. +-- RLB 09/13/99 UPDATED APPLICABILITY CRITERIA FOR ADA 95. + +SEPARATE (CA2009F0M) +PROCEDURE PROC1 IS +BEGIN + PVAR1 := PCON1; +END PROC1; diff --git a/gcc/testsuite/ada/acats/tests/ca/ca2009f2.ada b/gcc/testsuite/ada/acats/tests/ca/ca2009f2.ada new file mode 100644 index 000000000..201a43835 --- /dev/null +++ b/gcc/testsuite/ada/acats/tests/ca/ca2009f2.ada @@ -0,0 +1,45 @@ +-- CA2009F2.ADA + +-- Grant of Unlimited Rights +-- +-- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687, +-- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained +-- unlimited rights in the software and documentation contained herein. +-- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making +-- this public release, the Government intends to confer upon all +-- recipients unlimited rights equal to those held by the Government. +-- These rights include rights to use, duplicate, release or disclose the +-- released technical data and computer software in whole or in part, in +-- any manner and for any purpose whatsoever, and to have or permit others +-- to do so. +-- +-- DISCLAIMER +-- +-- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR +-- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED +-- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE +-- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE +-- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A +-- PARTICULAR PURPOSE OF SAID MATERIAL. +--* +-- SEPARATE GENERIC FUNCTION BODY. +-- SPECIFICATION, BODY STUB, AND AN INSTANTIATION ARE +-- IN CA2009F0M.DEP. + +-- APPLICABILITY CRITERIA: +-- THIS UNIT MUST BE ACCEPTED BY ALL ADA 95 IMPLEMENTATIONS. + +-- HISTORY: +-- BHS 08/01/84 CREATED ORIGINAL TEST. +-- PWB 02/19/86 MODIFIED COMMENTS TO DESCRIBE RELATION TO OTHER +-- FILES AND POSSIBLE NON-APPLICABILITY. +-- BCB 01/05/88 MODIFIED HEADER. +-- EDS 08/04/98 REMOVE CONTROL Z AT END OF FILE. +-- RLB 09/13/99 UPDATED APPLICABILITY CRITERIA FOR ADA 95. + +SEPARATE (CA2009F0M) +FUNCTION FUNC1 RETURN OBJ IS +BEGIN + FVAR1 := FCON1; + RETURN FVAR1; +END FUNC1; diff --git a/gcc/testsuite/ada/acats/tests/ca/ca2011b.ada b/gcc/testsuite/ada/acats/tests/ca/ca2011b.ada new file mode 100644 index 000000000..c1c3be5a0 --- /dev/null +++ b/gcc/testsuite/ada/acats/tests/ca/ca2011b.ada @@ -0,0 +1,118 @@ +-- CA2011B.ADA + +-- Grant of Unlimited Rights +-- +-- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687, +-- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained +-- unlimited rights in the software and documentation contained herein. +-- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making +-- this public release, the Government intends to confer upon all +-- recipients unlimited rights equal to those held by the Government. +-- These rights include rights to use, duplicate, release or disclose the +-- released technical data and computer software in whole or in part, in +-- any manner and for any purpose whatsoever, and to have or permit others +-- to do so. +-- +-- DISCLAIMER +-- +-- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR +-- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED +-- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF 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 SUBPROGRAM DECLARATION-STUB-BODY TRIPLE, THE +-- DECLARATION-STUB AND STUB-BODY SPECIFICATIONS CAN CONFORM, BUT +-- THE DECLARATION-BODY SPECIFICATIONS NEED NOT. + +-- HISTORY: +-- JET 08/01/88 CREATED ORIGINAL TEST. + +PACKAGE CA2011B0 IS + SUBTYPE T IS INTEGER RANGE -100 .. 100; + I : T := 0; +END CA2011B0; + +WITH CA2011B0; USE CA2011B0; +PACKAGE CA2011B1 IS + PROCEDURE P1 (X : CA2011B0.T); + PROCEDURE P2 (X : T); +END CA2011B1; + +WITH REPORT; USE REPORT; +PRAGMA ELABORATE (REPORT); +PACKAGE BODY CA2011B1 IS + PACKAGE CA2011BX RENAMES CA2011B0; + PROCEDURE P1 (X : T) IS SEPARATE; + PROCEDURE P2 (X : CA2011BX.T) IS SEPARATE; +END CA2011B1; + +SEPARATE (CA2011B1) +PROCEDURE P1 (X : CA2011BX.T) IS +BEGIN + I := IDENT_INT(X); +END P1; + +SEPARATE (CA2011B1) +PROCEDURE P2 (X : CA2011BX.T) IS +BEGIN + I := IDENT_INT(X); +END P2; + +WITH REPORT; USE REPORT; +WITH CA2011B0, CA2011B1; +PROCEDURE CA2011B IS + + PACKAGE P1 IS + SUBTYPE T IS INTEGER RANGE -100 .. 100; + END P1; + USE P1; + + FUNCTION F1 RETURN P1.T; + FUNCTION F2 RETURN T; + + PACKAGE P2 RENAMES P1; + + FUNCTION F1 RETURN T IS SEPARATE; + FUNCTION F2 RETURN P2.T IS SEPARATE; + +BEGIN + TEST ("CA2011B", "CHECK THAT FOR A SUBPROGRAM DECLARATION-STUB-" & + "BODY TRIPLE, THE DECLARATION-STUB AND STUB-" & + "BODY SPECIFICATIONS CAN CONFORM, BUT THE " & + "DECLARATON-BODY SPECIFICATIONS NEED NOT"); + + IF F1 /= IDENT_INT(100) THEN + FAILED ("INCORRECT RETURN VALUE FROM FUNCTION 1"); + END IF; + + IF F2 /= IDENT_INT(-100) THEN + FAILED ("INCORRECT RETURN VALUE FROM FUNCTION 2"); + END IF; + + CA2011B1.P1(3); + IF CA2011B0.I /= IDENT_INT(3) THEN + FAILED ("INCORRECT RETURN VALUE FROM PROCEDURE 1"); + END IF; + + CA2011B1.P2(4); + IF CA2011B0.I /= IDENT_INT(4) THEN + FAILED ("INCORRECT RETURN VALUE FROM PROCEDURE 2"); + END IF; + + RESULT; +END CA2011B; + +SEPARATE (CA2011B) +FUNCTION F1 RETURN P2.T IS +BEGIN + RETURN 100; +END F1; + +SEPARATE (CA2011B) +FUNCTION F2 RETURN P2.T IS +BEGIN + RETURN -100; +END F2; diff --git a/gcc/testsuite/ada/acats/tests/ca/ca21001.a b/gcc/testsuite/ada/acats/tests/ca/ca21001.a new file mode 100644 index 000000000..1056b65bf --- /dev/null +++ b/gcc/testsuite/ada/acats/tests/ca/ca21001.a @@ -0,0 +1,152 @@ +-- CA21001.A +-- +-- Grant of Unlimited Rights +-- +-- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687 and +-- F08630-91-C-0015, the U.S. Government obtained unlimited rights in the +-- software and documentation contained herein. Unlimited rights are +-- defined in DFAR 252.227-7013(a)(19). By making this public release, +-- the Government intends to confer upon all recipients unlimited rights +-- equal to those held by the Government. These rights include rights to +-- use, duplicate, release or disclose the released technical data and +-- computer software in whole or in part, in any manner and for any purpose +-- whatsoever, and to have or permit others to do so. +-- +-- DISCLAIMER +-- +-- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR +-- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED +-- WARRANTY AS TO ANY MATTER WHATSOVER, INCLUDING THE CONDITIONS OF THE +-- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE +-- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A +-- PARTICULAR PURPOSE OF SAID MATERIAL. +--* +-- +-- OBJECTIVE +-- Check the requirements of the revised 10.2.1(11) from Technical +-- Corrigendum 1 (originally discussed as AI95-00002). +-- A package subunit whose parent is a preelaborated subprogram need +-- not be preelaborable. +-- +-- TEST DESCRIPTION +-- We create several preelaborated library procedures with +-- non-preelaborable package body subunits. We try various levels +-- of nesting of package and procedure subunits. +-- +-- CHANGE HISTORY: +-- 29 JUN 1999 RAD Initial Version +-- 23 SEP 1999 RLB Improved comments, renamed, issued. +-- +--! + +procedure CA21001_1(X: out Integer); + pragma Preelaborate(CA21001_1); + +procedure CA21001_1(X: out Integer) is + function F return Integer is separate; + + package Sub is + function G(X: Integer) return Integer; + -- Returns X + 1. + Not_Preelaborable: Integer := F; -- OK, by AI-2. + end Sub; + + package body Sub is separate; + +begin + X := -1; + X := F; + X := Sub.G(X); +end CA21001_1; + +separate(CA21001_1) +package body Sub is + package Sub_Sub is + -- Empty. + end Sub_Sub; + package body Sub_Sub is separate; + + function G(X: Integer) return Integer is separate; +begin + Not_Preelaborable := G(F); -- OK, by AI-2. + if Not_Preelaborable /= 101 then + raise Program_Error; -- Can't call Report.Failed, here, + -- because Report is not preelaborated. + end if; +end Sub; + +separate(CA21001_1.Sub) +package body Sub_Sub is +begin + X := X; -- OK by AI-2. +end Sub_Sub; + +separate(CA21001_1.Sub) +function G(X: Integer) return Integer is + + package G_Sub is + function H(X: Integer) return Integer; + -- Returns X + 1. + Not_Preelaborable: Integer := F; -- OK, by AI-2. + end G_Sub; + package body G_Sub is separate; + +begin + return G_Sub.H(X); +end G; + +separate(CA21001_1.Sub.G) +package body G_Sub is + function H(X: Integer) return Integer is separate; +begin + Not_Preelaborable := H(F); -- OK, by AI-2. + if Not_Preelaborable /= 101 then + raise Program_Error; -- Can't call Report.Failed, here, + -- because Report is not preelaborated. + end if; +end G_Sub; + +separate(CA21001_1.Sub.G.G_Sub) +function H(X: Integer) return Integer is +begin + return X + 1; +end H; + +separate(CA21001_1) +function F return Integer is + + package F_Sub is + -- Empty. + end F_Sub; + + package body F_Sub is separate; +begin + return 100; +end F; + +separate(CA21001_1.F) +package body F_Sub is + True_Var: Boolean; +begin + True_Var := True; + if True_Var then -- OK by AI-2. + X := X; + else + X := X + 2; + end if; +end F_Sub; + +with Report; use Report; +with CA21001_1; +procedure CA21001 is + X: Integer := 0; +begin + Test("CA21001", + "Test that a package subunit whose parent is a preelaborated" + & " subprogram need not be preelaborable"); + CA21001_1(X); + if X /= 101 then + Failed("Bad value for X"); + end if; + Result; +end CA21001; diff --git a/gcc/testsuite/ada/acats/tests/ca/ca3011a0.ada b/gcc/testsuite/ada/acats/tests/ca/ca3011a0.ada new file mode 100644 index 000000000..fdbc141a3 --- /dev/null +++ b/gcc/testsuite/ada/acats/tests/ca/ca3011a0.ada @@ -0,0 +1,74 @@ +-- CA3011A0.ADA + +-- Grant of Unlimited Rights +-- +-- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687, +-- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained +-- unlimited rights in the software and documentation contained herein. +-- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making +-- this public release, the Government intends to confer upon all +-- recipients unlimited rights equal to those held by the Government. +-- These rights include rights to use, duplicate, release or disclose the +-- released technical data and computer software in whole or in part, in +-- any manner and for any purpose whatsoever, and to have or permit others +-- to do so. +-- +-- DISCLAIMER +-- +-- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR +-- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED +-- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE +-- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE +-- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A +-- PARTICULAR PURPOSE OF SAID MATERIAL. +--* +-- A GENERIC UNIT. +-- SUBUNITS ARE IN CA3011A1, CA3011A2, AND CA3011A3. +-- INSTANTIATION IS IN CA3011A4M. + +-- APPLICABILITY CRITERIA: +-- THIS UNIT MUST BE ACCEPTED BY ALL ADA 95 IMPLEMENTATIONS. + +-- HISTORY: +-- RJW 09/22/86 CREATED ORIGINAL TEST. +-- BCB 01/05/88 MODIFIED HEADER. +-- RLB 09/13/99 UPDATED APPLICABILITY CRITERIA FOR ADA 95. + +WITH REPORT; USE REPORT; + +GENERIC + TYPE T IS (<>); + X : T; +PROCEDURE CA3011A0 (Z : OUT T); + +PROCEDURE CA3011A0 (Z : OUT T) IS + T1 : T; + + FUNCTION CA3011A1 RETURN T IS SEPARATE; + + PROCEDURE CA3011A2 (Y : OUT T) IS SEPARATE; + + PACKAGE CA3011A3 IS + FUNCTION CA3011A3F RETURN T; + END CA3011A3; + + PACKAGE BODY CA3011A3 IS SEPARATE; + +BEGIN + IF CA3011A1 /= X THEN + FAILED ( "INCORRECT VALUE RETURNED BY FUNCTION CA3011A1" ); + END IF; + + CA3011A2 (T1); + + IF T1 /= X THEN + FAILED ( "INCORRECT VALUE RETURNED BY PROCEDURE CA3011A2 " ); + END IF; + + IF CA3011A3.CA3011A3F /= X THEN + FAILED ( "INCORRECT VALUE RETURNED BY FUNCTION CA3011A3F " ); + END IF; + + Z := X; + +END CA3011A0; diff --git a/gcc/testsuite/ada/acats/tests/ca/ca3011a1.ada b/gcc/testsuite/ada/acats/tests/ca/ca3011a1.ada new file mode 100644 index 000000000..5c53cf35b --- /dev/null +++ b/gcc/testsuite/ada/acats/tests/ca/ca3011a1.ada @@ -0,0 +1,42 @@ +-- CA3011A1.ADA + +-- Grant of Unlimited Rights +-- +-- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687, +-- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained +-- unlimited rights in the software and documentation contained herein. +-- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making +-- this public release, the Government intends to confer upon all +-- recipients unlimited rights equal to those held by the Government. +-- These rights include rights to use, duplicate, release or disclose the +-- released technical data and computer software in whole or in part, in +-- any manner and for any purpose whatsoever, and to have or permit others +-- to do so. +-- +-- DISCLAIMER +-- +-- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR +-- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED +-- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE +-- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE +-- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A +-- PARTICULAR PURPOSE OF SAID MATERIAL. +--* +-- A SUBUNIT OF A GENERIC UNIT. +-- THE GENERIC UNIT IS IN CA3011A0. +-- INSTANTIATION IS IN CA0011A4M. + +-- APPLICABILITY CRITERIA: +-- THIS UNIT MUST BE ACCEPTED BY ALL ADA 95 IMPLEMENTATIONS. + +-- HISTORY: +-- RJW 09/22/86 CREATED ORIGINAL TEST. +-- BCB 01/05/88 MODIFIED HEADER. +-- RLB 09/13/99 UPDATED APPLICABILITY CRITERIA FOR ADA 95. + +SEPARATE (CA3011A0) +FUNCTION CA3011A1 RETURN T IS + +BEGIN + RETURN X; +END CA3011A1; diff --git a/gcc/testsuite/ada/acats/tests/ca/ca3011a2.ada b/gcc/testsuite/ada/acats/tests/ca/ca3011a2.ada new file mode 100644 index 000000000..87aacfa18 --- /dev/null +++ b/gcc/testsuite/ada/acats/tests/ca/ca3011a2.ada @@ -0,0 +1,42 @@ +-- CA3011A2.ADA + +-- Grant of Unlimited Rights +-- +-- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687, +-- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained +-- unlimited rights in the software and documentation contained herein. +-- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making +-- this public release, the Government intends to confer upon all +-- recipients unlimited rights equal to those held by the Government. +-- These rights include rights to use, duplicate, release or disclose the +-- released technical data and computer software in whole or in part, in +-- any manner and for any purpose whatsoever, and to have or permit others +-- to do so. +-- +-- DISCLAIMER +-- +-- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR +-- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED +-- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE +-- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE +-- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A +-- PARTICULAR PURPOSE OF SAID MATERIAL. +--* +-- A SUBUNIT OF A GENERIC UNIT. +-- THE GENERIC UNIT IS IN CA3011A0. +-- INSTANTIATION IS IN CA3011A4M. + +-- APPLICABILITY CRITERIA: +-- THIS UNIT MUST BE ACCEPTED BY ALL ADA 95 IMPLEMENTATIONS. + +-- HISTORY: +-- RJW 09/22/86 CREATED ORIGINAL TEST. +-- BCB 01/05/88 MODIFIED HEADER. +-- RLB 09/13/99 UPDATED APPLICABILITY CRITERIA FOR ADA 95. + +SEPARATE (CA3011A0) +PROCEDURE CA3011A2 (Y : OUT T) IS + +BEGIN + Y := X; +END CA3011A2; diff --git a/gcc/testsuite/ada/acats/tests/ca/ca3011a3.ada b/gcc/testsuite/ada/acats/tests/ca/ca3011a3.ada new file mode 100644 index 000000000..eb582b84b --- /dev/null +++ b/gcc/testsuite/ada/acats/tests/ca/ca3011a3.ada @@ -0,0 +1,43 @@ +-- CA3011A3.ADA + +-- Grant of Unlimited Rights +-- +-- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687, +-- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained +-- unlimited rights in the software and documentation contained herein. +-- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making +-- this public release, the Government intends to confer upon all +-- recipients unlimited rights equal to those held by the Government. +-- These rights include rights to use, duplicate, release or disclose the +-- released technical data and computer software in whole or in part, in +-- any manner and for any purpose whatsoever, and to have or permit others +-- to do so. +-- +-- DISCLAIMER +-- +-- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR +-- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED +-- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE +-- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE +-- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A +-- PARTICULAR PURPOSE OF SAID MATERIAL. +--* +-- A SUBUNIT OF A GENERIC UNIT. +-- THE GENERIC UNIT IS IN CA3011A0. +-- INSTANTIATION IS IN CA3011A4M. + +-- APPLICABILITY CRITERIA: +-- THIS UNIT MUST BE ACCEPTED BY ALL ADA 95 IMPLEMENTATIONS. + +-- HISTORY: +-- RJW 09/22/86 CREATED ORIGINAL TEST. +-- BCB 01/05/88 MODIFIED HEADER. +-- RLB 09/13/99 UPDATED APPLICABILITY CRITERIA FOR ADA 95. + +SEPARATE (CA3011A0) +PACKAGE BODY CA3011A3 IS + FUNCTION CA3011A3F RETURN T IS + BEGIN + RETURN X; + END; +END CA3011A3; diff --git a/gcc/testsuite/ada/acats/tests/ca/ca3011a4.ada b/gcc/testsuite/ada/acats/tests/ca/ca3011a4.ada new file mode 100644 index 000000000..70cad219c --- /dev/null +++ b/gcc/testsuite/ada/acats/tests/ca/ca3011a4.ada @@ -0,0 +1,61 @@ +-- CA3011A4M.ADA + +-- Grant of Unlimited Rights +-- +-- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687, +-- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained +-- unlimited rights in the software and documentation contained herein. +-- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making +-- this public release, the Government intends to confer upon all +-- recipients unlimited rights equal to those held by the Government. +-- These rights include rights to use, duplicate, release or disclose the +-- released technical data and computer software in whole or in part, in +-- any manner and for any purpose whatsoever, and to have or permit others +-- to do so. +-- +-- DISCLAIMER +-- +-- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR +-- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED +-- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF 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 IMPLEMENTATION DOES NOT REQUIRE GENERIC UNIT BODIES AND +-- SUBUNITS TO BE COMPILED TOGETHER IN THE SAME FILE. + +-- SEPARATE FILES ARE: +-- CA3011A0 - A GENERIC UNIT. +-- CA3011A1, CA3011A2, CA3011A3 - SUBUNITS OF GENERIC UNIT. +-- CA3011A4M - THE MAIN PROCEDURE. + +-- APPLICABILITY CRITERIA: +-- THIS TEST MUST RUN AND REPORT "PASSED" FOR ALL ADA 95 IMPLEMENTATIONS. +-- THIS WAS NOT REQUIRED FOR ADA 83. + +-- HISTORY: +-- RJW 09/22/86 CREATED ORIGINAL TEST. +-- BCB 01/05/88 MODIFIED HEADER. +-- RLB 09/13/99 UPDATED APPLICABILITY CRITERIA FOR ADA 95. +-- RLB 09/15/99 REPAIRED OBJECTIVE FOR ADA 95. + +WITH REPORT; USE REPORT; +WITH CA3011A0; +PROCEDURE CA3011A4M IS + I : INTEGER; + PROCEDURE P IS NEW CA3011A0 (INTEGER, 22); + +BEGIN + TEST ( "CA3011A", "CHECK THAT AN IMPLEMENTATION DOES NOT REQUIRE " & + "GENERIC UNIT BODIES AND SUBUNITS TO BE " & + "COMPILED TOGETHER IN THE SAME FILE" ); + + P (I); + IF I /= 22 THEN + FAILED ( "INCORRECT INSTANTIATION" ); + END IF; + + RESULT; +END CA3011A4M; diff --git a/gcc/testsuite/ada/acats/tests/ca/ca5003a0.ada b/gcc/testsuite/ada/acats/tests/ca/ca5003a0.ada new file mode 100644 index 000000000..302314b4e --- /dev/null +++ b/gcc/testsuite/ada/acats/tests/ca/ca5003a0.ada @@ -0,0 +1,50 @@ +-- CA5003A0.ADA + +-- Grant of Unlimited Rights +-- +-- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687, +-- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained +-- unlimited rights in the software and documentation contained herein. +-- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making +-- this public release, the Government intends to confer upon all +-- recipients unlimited rights equal to those held by the Government. +-- These rights include rights to use, duplicate, release or disclose the +-- released technical data and computer software in whole or in part, in +-- any manner and for any purpose whatsoever, and to have or permit others +-- to do so. +-- +-- DISCLAIMER +-- +-- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR +-- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED +-- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE +-- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE +-- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A +-- PARTICULAR PURPOSE OF SAID MATERIAL. +--* +-- WKB 7/22/81 +-- JBG 10/6/83 + +PACKAGE CA5003A0 IS + + ORDER : STRING (1..5) := " "; + + INDEX : NATURAL := 1; + + FUNCTION SHOW_ELAB (UNIT : CHARACTER) RETURN INTEGER; + +END CA5003A0; + + +WITH REPORT; +USE REPORT; +PACKAGE BODY CA5003A0 IS + + FUNCTION SHOW_ELAB (UNIT : CHARACTER) RETURN INTEGER IS + BEGIN + ORDER (INDEX) := UNIT; + INDEX := INDEX + 1; + RETURN INDEX - 1; + END SHOW_ELAB; + +END CA5003A0; diff --git a/gcc/testsuite/ada/acats/tests/ca/ca5003a1.ada b/gcc/testsuite/ada/acats/tests/ca/ca5003a1.ada new file mode 100644 index 000000000..7f9f3b259 --- /dev/null +++ b/gcc/testsuite/ada/acats/tests/ca/ca5003a1.ada @@ -0,0 +1,34 @@ +-- CA5003A1.ADA + +-- Grant of Unlimited Rights +-- +-- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687, +-- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained +-- unlimited rights in the software and documentation contained herein. +-- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making +-- this public release, the Government intends to confer upon all +-- recipients unlimited rights equal to those held by the Government. +-- These rights include rights to use, duplicate, release or disclose the +-- released technical data and computer software in whole or in part, in +-- any manner and for any purpose whatsoever, and to have or permit others +-- to do so. +-- +-- DISCLAIMER +-- +-- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR +-- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED +-- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE +-- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE +-- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A +-- PARTICULAR PURPOSE OF SAID MATERIAL. +--* +-- WKB 7/22/81 +-- JBG 10/6/83 + +WITH CA5003A0; +USE CA5003A0; PRAGMA ELABORATE (CA5003A0); +PACKAGE CA5003A1 IS + + A1 : INTEGER := SHOW_ELAB ('1'); + +END CA5003A1; diff --git a/gcc/testsuite/ada/acats/tests/ca/ca5003a2.ada b/gcc/testsuite/ada/acats/tests/ca/ca5003a2.ada new file mode 100644 index 000000000..9d36ab2a0 --- /dev/null +++ b/gcc/testsuite/ada/acats/tests/ca/ca5003a2.ada @@ -0,0 +1,34 @@ +-- CA5003A2.ADA + +-- Grant of Unlimited Rights +-- +-- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687, +-- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained +-- unlimited rights in the software and documentation contained herein. +-- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making +-- this public release, the Government intends to confer upon all +-- recipients unlimited rights equal to those held by the Government. +-- These rights include rights to use, duplicate, release or disclose the +-- released technical data and computer software in whole or in part, in +-- any manner and for any purpose whatsoever, and to have or permit others +-- to do so. +-- +-- DISCLAIMER +-- +-- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR +-- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED +-- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE +-- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE +-- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A +-- PARTICULAR PURPOSE OF SAID MATERIAL. +--* +-- WKB 7/22/81 +-- JBG 10/6/83 + +WITH CA5003A0; +USE CA5003A0; PRAGMA ELABORATE (CA5003A0); +PACKAGE CA5003A2 IS + + A2 : INTEGER := SHOW_ELAB ('2'); + +END CA5003A2; diff --git a/gcc/testsuite/ada/acats/tests/ca/ca5003a3.ada b/gcc/testsuite/ada/acats/tests/ca/ca5003a3.ada new file mode 100644 index 000000000..96145677c --- /dev/null +++ b/gcc/testsuite/ada/acats/tests/ca/ca5003a3.ada @@ -0,0 +1,34 @@ +-- CA5003A3.ADA + +-- Grant of Unlimited Rights +-- +-- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687, +-- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained +-- unlimited rights in the software and documentation contained herein. +-- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making +-- this public release, the Government intends to confer upon all +-- recipients unlimited rights equal to those held by the Government. +-- These rights include rights to use, duplicate, release or disclose the +-- released technical data and computer software in whole or in part, in +-- any manner and for any purpose whatsoever, and to have or permit others +-- to do so. +-- +-- DISCLAIMER +-- +-- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR +-- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED +-- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE +-- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE +-- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A +-- PARTICULAR PURPOSE OF SAID MATERIAL. +--* +-- WKB 7/22/81 +-- JBG 10/6/83 + +WITH CA5003A0, CA5003A2; +USE CA5003A0; PRAGMA ELABORATE (CA5003A0); +PACKAGE CA5003A3 IS + + A3 : INTEGER := SHOW_ELAB ('3'); + +END CA5003A3; diff --git a/gcc/testsuite/ada/acats/tests/ca/ca5003a4.ada b/gcc/testsuite/ada/acats/tests/ca/ca5003a4.ada new file mode 100644 index 000000000..908b39e42 --- /dev/null +++ b/gcc/testsuite/ada/acats/tests/ca/ca5003a4.ada @@ -0,0 +1,34 @@ +-- CA5003A4.ADA + +-- Grant of Unlimited Rights +-- +-- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687, +-- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained +-- unlimited rights in the software and documentation contained herein. +-- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making +-- this public release, the Government intends to confer upon all +-- recipients unlimited rights equal to those held by the Government. +-- These rights include rights to use, duplicate, release or disclose the +-- released technical data and computer software in whole or in part, in +-- any manner and for any purpose whatsoever, and to have or permit others +-- to do so. +-- +-- DISCLAIMER +-- +-- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR +-- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED +-- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE +-- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE +-- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A +-- PARTICULAR PURPOSE OF SAID MATERIAL. +--* +-- WKB 7/22/81 +-- JBG 10/6/83 + +WITH CA5003A0, CA5003A2; +USE CA5003A0; PRAGMA ELABORATE (CA5003A0); +PACKAGE CA5003A4 IS + + A4 : INTEGER := SHOW_ELAB ('4'); + +END CA5003A4; diff --git a/gcc/testsuite/ada/acats/tests/ca/ca5003a5.ada b/gcc/testsuite/ada/acats/tests/ca/ca5003a5.ada new file mode 100644 index 000000000..a8e07fea9 --- /dev/null +++ b/gcc/testsuite/ada/acats/tests/ca/ca5003a5.ada @@ -0,0 +1,34 @@ +-- CA5003A5.ADA + +-- Grant of Unlimited Rights +-- +-- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687, +-- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained +-- unlimited rights in the software and documentation contained herein. +-- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making +-- this public release, the Government intends to confer upon all +-- recipients unlimited rights equal to those held by the Government. +-- These rights include rights to use, duplicate, release or disclose the +-- released technical data and computer software in whole or in part, in +-- any manner and for any purpose whatsoever, and to have or permit others +-- to do so. +-- +-- DISCLAIMER +-- +-- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR +-- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED +-- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE +-- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE +-- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A +-- PARTICULAR PURPOSE OF SAID MATERIAL. +--* +-- WKB 7/22/81 +-- JBG 10/6/83 + +WITH CA5003A0, CA5003A3, CA5003A4; +USE CA5003A0; PRAGMA ELABORATE (CA5003A0); +PACKAGE CA5003A5 IS + + A5 : INTEGER := SHOW_ELAB ('5'); + +END CA5003A5; diff --git a/gcc/testsuite/ada/acats/tests/ca/ca5003a6.ada b/gcc/testsuite/ada/acats/tests/ca/ca5003a6.ada new file mode 100644 index 000000000..df12c4e88 --- /dev/null +++ b/gcc/testsuite/ada/acats/tests/ca/ca5003a6.ada @@ -0,0 +1,71 @@ +-- CA5003A6M.ADA + +-- Grant of Unlimited Rights +-- +-- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687, +-- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained +-- unlimited rights in the software and documentation contained herein. +-- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making +-- this public release, the Government intends to confer upon all +-- recipients unlimited rights equal to those held by the Government. +-- These rights include rights to use, duplicate, release or disclose the +-- released technical data and computer software in whole or in part, in +-- any manner and for any purpose whatsoever, and to have or permit others +-- to do so. +-- +-- DISCLAIMER +-- +-- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR +-- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED +-- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF 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 LIBRARY UNITS REQUIRED BY +-- A MAIN PROGRAM IS PERFORMED CONSISTENTLY WITH THE PARTIAL +-- ORDERING DEFINED BY THE COMPILATION ORDER RULES. + +-- SEPARATE FILES ARE: +-- CA5003A0 A LIBRARY PACKAGE. +-- CA5003A1 A LIBRARY PACKAGE SPECIFICATION. +-- CA5003A2 A LIBRARY PACKAGE SPECIFICATION. +-- CA5003A3 A LIBRARY PACKAGE SPECIFICATION. +-- CA5003A4 A LIBRARY PACKAGE SPECIFICATION. +-- CA5003A5 A LIBRARY PACKAGE SPECIFICATION. +-- CA5003A6M THE MAIN PROCEDURE. + +-- PACKAGE A5 MUST BE ELABORATED AFTER A2, A3, AND A4. +-- PACKAGE A3 MUST BE ELABORATED AFTER A2. +-- PACKAGE A4 MUST BE ELABORATED AFTER A2. + +-- WKB 7/22/81 +-- JBG 10/6/83 + +WITH REPORT, CA5003A0; +USE REPORT, CA5003A0; +WITH CA5003A1, CA5003A5; +PROCEDURE CA5003A6M IS + +BEGIN + + TEST ("CA5003A", "CHECK THAT ELABORATION ORDER IS CONSISTENT " & + "WITH PARTIAL ORDERING REQUIREMENTS"); + + COMMENT ("ACTUAL ELABORATION ORDER WAS " & ORDER); + + IF ORDER /= "12345" AND + ORDER /= "12435" AND + ORDER /= "21345" AND + ORDER /= "21435" AND + ORDER /= "23145" AND + ORDER /= "24135" AND + ORDER /= "23415" AND + ORDER /= "24315" AND + ORDER /= "23451" AND + ORDER /= "24351" THEN + FAILED ("ILLEGAL ELABORATION ORDER"); + END IF; + + RESULT; +END CA5003A6M; diff --git a/gcc/testsuite/ada/acats/tests/ca/ca5003b0.ada b/gcc/testsuite/ada/acats/tests/ca/ca5003b0.ada new file mode 100644 index 000000000..9851ca328 --- /dev/null +++ b/gcc/testsuite/ada/acats/tests/ca/ca5003b0.ada @@ -0,0 +1,51 @@ +-- CA5003B0.ADA + +-- Grant of Unlimited Rights +-- +-- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687, +-- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained +-- unlimited rights in the software and documentation contained herein. +-- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making +-- this public release, the Government intends to confer upon all +-- recipients unlimited rights equal to those held by the Government. +-- These rights include rights to use, duplicate, release or disclose the +-- released technical data and computer software in whole or in part, in +-- any manner and for any purpose whatsoever, and to have or permit others +-- to do so. +-- +-- DISCLAIMER +-- +-- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR +-- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED +-- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE +-- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE +-- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A +-- PARTICULAR PURPOSE OF SAID MATERIAL. +--* +-- WKB 7/22/81 +-- JBG 10/6/83 +-- BHS 8/02/84 +-- JRK 9/20/84 + + +PACKAGE CA5003B0 IS + + ORDER : STRING (1..4) := " "; + + INDEX : NATURAL := 1; + + FUNCTION SHOW_ELAB (UNIT : CHARACTER) RETURN INTEGER; + +END CA5003B0; + + +PACKAGE BODY CA5003B0 IS + + FUNCTION SHOW_ELAB (UNIT : CHARACTER) RETURN INTEGER IS + BEGIN + ORDER (INDEX) := UNIT; + INDEX := INDEX + 1; + RETURN INDEX - 1; + END SHOW_ELAB; + +END CA5003B0; diff --git a/gcc/testsuite/ada/acats/tests/ca/ca5003b1.ada b/gcc/testsuite/ada/acats/tests/ca/ca5003b1.ada new file mode 100644 index 000000000..ba70ecc38 --- /dev/null +++ b/gcc/testsuite/ada/acats/tests/ca/ca5003b1.ada @@ -0,0 +1,46 @@ +-- CA5003B1.ADA + +-- Grant of Unlimited Rights +-- +-- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687, +-- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained +-- unlimited rights in the software and documentation contained herein. +-- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making +-- this public release, the Government intends to confer upon all +-- recipients unlimited rights equal to those held by the Government. +-- These rights include rights to use, duplicate, release or disclose the +-- released technical data and computer software in whole or in part, in +-- any manner and for any purpose whatsoever, and to have or permit others +-- to do so. +-- +-- DISCLAIMER +-- +-- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR +-- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED +-- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE +-- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE +-- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A +-- PARTICULAR PURPOSE OF SAID MATERIAL. +--* +-- WKB 7/22/81 +-- JBG 10/6/83 +-- BHS 8/02/84 +-- JRK 9/20/84 + + +WITH CA5003B0; USE CA5003B0; PRAGMA ELABORATE (CA5003B0); +PACKAGE CA5003B1 IS + + PACKAGE CA5003B2 IS + PROCEDURE P1; + END CA5003B2; + +END CA5003B1; + + +PACKAGE BODY CA5003B1 IS + + A1 : INTEGER := SHOW_ELAB ('1'); + PACKAGE BODY CA5003B2 IS SEPARATE; + +END CA5003B1; diff --git a/gcc/testsuite/ada/acats/tests/ca/ca5003b2.ada b/gcc/testsuite/ada/acats/tests/ca/ca5003b2.ada new file mode 100644 index 000000000..a524a0088 --- /dev/null +++ b/gcc/testsuite/ada/acats/tests/ca/ca5003b2.ada @@ -0,0 +1,45 @@ +-- CA5003B2.ADA + +-- Grant of Unlimited Rights +-- +-- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687, +-- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained +-- unlimited rights in the software and documentation contained herein. +-- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making +-- this public release, the Government intends to confer upon all +-- recipients unlimited rights equal to those held by the Government. +-- These rights include rights to use, duplicate, release or disclose the +-- released technical data and computer software in whole or in part, in +-- any manner and for any purpose whatsoever, and to have or permit others +-- to do so. +-- +-- DISCLAIMER +-- +-- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR +-- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED +-- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE +-- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE +-- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A +-- PARTICULAR PURPOSE OF SAID MATERIAL. +--* +-- BHS 8/02/84 +-- JRK 9/20/84 + +WITH CA5003B0; USE CA5003B0; PRAGMA ELABORATE (CA5003B0); +SEPARATE (CA5003B1) +PACKAGE BODY CA5003B2 IS + + A2 : INTEGER := SHOW_ELAB ('2'); + + PROCEDURE P1 IS + BEGIN + NULL; + END P1; + + PACKAGE CA5003B4 IS + PROCEDURE P2; + END CA5003B4; + + PACKAGE BODY CA5003B4 IS SEPARATE; + +END CA5003B2; diff --git a/gcc/testsuite/ada/acats/tests/ca/ca5003b3.ada b/gcc/testsuite/ada/acats/tests/ca/ca5003b3.ada new file mode 100644 index 000000000..8706a0637 --- /dev/null +++ b/gcc/testsuite/ada/acats/tests/ca/ca5003b3.ada @@ -0,0 +1,35 @@ +-- CA5003B3.ADA + +-- Grant of Unlimited Rights +-- +-- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687, +-- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained +-- unlimited rights in the software and documentation contained herein. +-- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making +-- this public release, the Government intends to confer upon all +-- recipients unlimited rights equal to those held by the Government. +-- These rights include rights to use, duplicate, release or disclose the +-- released technical data and computer software in whole or in part, in +-- any manner and for any purpose whatsoever, and to have or permit others +-- to do so. +-- +-- DISCLAIMER +-- +-- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR +-- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED +-- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE +-- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE +-- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A +-- PARTICULAR PURPOSE OF SAID MATERIAL. +--* +-- WKB 7/22/81 +-- JBG 10/6/83 +-- BHS 8/02/84 +-- JRK 9/20/84 + +WITH CA5003B0; USE CA5003B0; PRAGMA ELABORATE (CA5003B0); +PACKAGE CA5003B3 IS + + A3 : INTEGER := SHOW_ELAB ('3'); + +END CA5003B3; diff --git a/gcc/testsuite/ada/acats/tests/ca/ca5003b4.ada b/gcc/testsuite/ada/acats/tests/ca/ca5003b4.ada new file mode 100644 index 000000000..d3c2f7e2d --- /dev/null +++ b/gcc/testsuite/ada/acats/tests/ca/ca5003b4.ada @@ -0,0 +1,40 @@ +-- CA5003B4.ADA + +-- Grant of Unlimited Rights +-- +-- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687, +-- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained +-- unlimited rights in the software and documentation contained herein. +-- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making +-- this public release, the Government intends to confer upon all +-- recipients unlimited rights equal to those held by the Government. +-- These rights include rights to use, duplicate, release or disclose the +-- released technical data and computer software in whole or in part, in +-- any manner and for any purpose whatsoever, and to have or permit others +-- to do so. +-- +-- DISCLAIMER +-- +-- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR +-- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED +-- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE +-- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE +-- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A +-- PARTICULAR PURPOSE OF SAID MATERIAL. +--* +-- BHS 8/02/84 +-- JRK 9/20/84 + +WITH CA5003B3; -- MUST BE ELABORATED BEFORE CA5003B1. +WITH CA5003B0; USE CA5003B0; PRAGMA ELABORATE (CA5003B0); +SEPARATE (CA5003B1.CA5003B2) +PACKAGE BODY CA5003B4 IS + + A4 : INTEGER := SHOW_ELAB ('4'); + + PROCEDURE P2 IS + BEGIN + NULL; + END P2; + +END CA5003B4; diff --git a/gcc/testsuite/ada/acats/tests/ca/ca5003b5.ada b/gcc/testsuite/ada/acats/tests/ca/ca5003b5.ada new file mode 100644 index 000000000..4beb61ed1 --- /dev/null +++ b/gcc/testsuite/ada/acats/tests/ca/ca5003b5.ada @@ -0,0 +1,65 @@ +-- CA5003B5M.ADA + +-- Grant of Unlimited Rights +-- +-- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687, +-- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained +-- unlimited rights in the software and documentation contained herein. +-- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making +-- this public release, the Government intends to confer upon all +-- recipients unlimited rights equal to those held by the Government. +-- These rights include rights to use, duplicate, release or disclose the +-- released technical data and computer software in whole or in part, in +-- any manner and for any purpose whatsoever, and to have or permit others +-- to do so. +-- +-- DISCLAIMER +-- +-- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR +-- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED +-- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF 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 LIBRARY UNITS REQUIRED BY +-- A MAIN PROGRAM IS PERFORMED CONSISTENTLY WITH THE PARTIAL +-- ORDERING DEFINED BY THE COMPILATION ORDER RULES. +-- IN PARTICULAR, CHECK THAT A LIBRARY UNIT MENTIONED IN THE +-- WITH_CLAUSE OF A SUBUNIT IS ELABORATED PRIOR TO THE BODY OF +-- THE ANCESTOR UNIT. + +-- SEPARATE FILES ARE: +-- CA5003B0 A LIBRARY PACKAGE. +-- CA5003B1 A LIBRARY PACKAGE. +-- CA5003B2 A SUBUNIT PACKAGE BODY (_B1._B2). +-- CA5003B3 A LIBRARY PACKAGE DECLARATION. +-- CA5003B4 A SUBUNIT PACKAGE BODY (_B1._B2._B4). +-- CA5003B5M THE MAIN PROCEDURE. + +-- LIBRARY PACKAGES MUST BE ELABORATED IN ORDER: _B0, _B3, _B1. +-- PARENT UNITS MUST BE ELABORATED BEFORE THEIR SUBUNITS. + +-- WKB 7/22/81 +-- JBG 10/6/83 +-- BHS 8/02/84 +-- JRK 9/20/84 + +WITH REPORT, CA5003B0; +USE REPORT, CA5003B0; +WITH CA5003B1; +PROCEDURE CA5003B5M IS + +BEGIN + TEST ("CA5003B", "CHECK THAT UNITS IN WITH_CLAUSES OF " & + "SUBUNITS ARE ELABORATED PRIOR TO THE " & + "BODY OF THE ANCESTOR UNIT"); + + COMMENT ("ACTUAL ELABORATION ORDER WAS " & ORDER); + + IF ORDER /= "3124" THEN + FAILED ("ILLEGAL ELABORATION ORDER"); + END IF; + + RESULT; +END CA5003B5M; diff --git a/gcc/testsuite/ada/acats/tests/ca/ca5004a.ada b/gcc/testsuite/ada/acats/tests/ca/ca5004a.ada new file mode 100644 index 000000000..34a735ef0 --- /dev/null +++ b/gcc/testsuite/ada/acats/tests/ca/ca5004a.ada @@ -0,0 +1,105 @@ +-- CA5004A.ADA + +-- Grant of Unlimited Rights +-- +-- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687, +-- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained +-- unlimited rights in the software and documentation contained herein. +-- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making +-- this public release, the Government intends to confer upon all +-- recipients unlimited rights equal to those held by the Government. +-- These rights include rights to use, duplicate, release or disclose the +-- released technical data and computer software in whole or in part, in +-- any manner and for any purpose whatsoever, and to have or permit others +-- to do so. +-- +-- DISCLAIMER +-- +-- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR +-- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED +-- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE +-- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE +-- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A +-- PARTICULAR PURPOSE OF SAID MATERIAL. +--* +-- CHECK THAT IF PRAGMA ELABORATE IS APPLIED TO A PACKAGE THAT DECLARES +-- A TASK OBJECT, THE IMPLICIT PACKAGE BODY IS ELABORATED AND THE TASK +-- IS ACTIVATED. + +-- BHS 8/03/84 +-- JRK 9/20/84 +-- PWN 01/31/95 ADDED A PROCEDURE TO REQUIRE A BODY FOR ADA 9X. + + +PACKAGE CA5004A0 IS + + TASK TYPE TSK IS + ENTRY E (VAR : OUT INTEGER); + END TSK; + +END CA5004A0; + + +PACKAGE BODY CA5004A0 IS + + TASK BODY TSK IS + BEGIN + ACCEPT E (VAR : OUT INTEGER) DO + VAR := 4; + END E; + END TSK; + +END CA5004A0; + + +WITH CA5004A0; USE CA5004A0; PRAGMA ELABORATE (CA5004A0); +PACKAGE CA5004A1 IS + + T : TSK; + +END CA5004A1; + + +PACKAGE CA5004A2 IS + PROCEDURE REQUIRE_BODY; +END CA5004A2; + + +WITH REPORT; USE REPORT; +WITH CA5004A1; USE CA5004A1; +PRAGMA ELABORATE (CA5004A1, REPORT); +PACKAGE BODY CA5004A2 IS + + I : INTEGER := 1; + + PROCEDURE REQUIRE_BODY IS + BEGIN + NULL; + END; +BEGIN + + TEST ("CA5004A", "APPLYING PRAGMA ELABORATE TO A PACKAGE " & + "DECLARING A TASK OBJECT CAUSES IMPLICIT " & + "BODY ELABORATION AND TASK ACTIVATION"); + + SELECT + T.E(I); + IF I /= 4 THEN + FAILED ("TASK NOT EXECUTED PROPERLY"); + END IF; + OR + DELAY 10.0; + FAILED ("TASK NOT ACTIVATED AFTER 10 SECONDS"); + END SELECT; + +END CA5004A2; + + +WITH CA5004A2; +WITH REPORT; USE REPORT; +PROCEDURE CA5004A IS +BEGIN + + RESULT; + +END CA5004A; diff --git a/gcc/testsuite/ada/acats/tests/ca/ca5004b0.ada b/gcc/testsuite/ada/acats/tests/ca/ca5004b0.ada new file mode 100644 index 000000000..bb7947027 --- /dev/null +++ b/gcc/testsuite/ada/acats/tests/ca/ca5004b0.ada @@ -0,0 +1,64 @@ +-- CA5004B0.ADA + +-- Grant of Unlimited Rights +-- +-- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687, +-- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained +-- unlimited rights in the software and documentation contained herein. +-- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making +-- this public release, the Government intends to confer upon all +-- recipients unlimited rights equal to those held by the Government. +-- These rights include rights to use, duplicate, release or disclose the +-- released technical data and computer software in whole or in part, in +-- any manner and for any purpose whatsoever, and to have or permit others +-- to do so. +-- +-- DISCLAIMER +-- +-- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR +-- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED +-- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF 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: See CA5004B2M.ADA +-- +-- SPECIAL INSTRUCTIONS: See CA5004B2M.ADA +-- +-- TEST FILES: +-- => CA5004B0.ADA +-- CA5004B1.ADA +-- CA5004B2M.ADA + +-- PWN 05/31/96 Split test into files without duplicate unit names. +-- RLB 03/11/99 Split test into files so that units that will be replaced +-- and units that won't are not in the same source file. + +------------------------------------------------------------- + +PACKAGE HEADER IS + + PROCEDURE WRONG (WHY : STRING); + +END HEADER; + + +WITH REPORT; USE REPORT; +PRAGMA ELABORATE (REPORT); +PACKAGE BODY HEADER IS + + PROCEDURE WRONG (WHY : STRING) IS + BEGIN + FAILED ("PACKAGE WITH " & WHY & " NOT ELABORATED " & + "CORRECTLY"); + END WRONG; + +BEGIN + + TEST ("CA5004B", "PRAGMA ELABORATE IS ACCEPTED AND OBEYED " & + "EVEN WHEN THE BODY OF THE UNIT NAMED IS " & + "MISSING OR OBSOLETE"); + +END HEADER; + diff --git a/gcc/testsuite/ada/acats/tests/ca/ca5004b1.ada b/gcc/testsuite/ada/acats/tests/ca/ca5004b1.ada new file mode 100644 index 000000000..068ae88a0 --- /dev/null +++ b/gcc/testsuite/ada/acats/tests/ca/ca5004b1.ada @@ -0,0 +1,56 @@ +-- CA5004B1.ADA + +-- Grant of Unlimited Rights +-- +-- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687, +-- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained +-- unlimited rights in the software and documentation contained herein. +-- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making +-- this public release, the Government intends to confer upon all +-- recipients unlimited rights equal to those held by the Government. +-- These rights include rights to use, duplicate, release or disclose the +-- released technical data and computer software in whole or in part, in +-- any manner and for any purpose whatsoever, and to have or permit others +-- to do so. +-- +-- DISCLAIMER +-- +-- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR +-- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED +-- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF 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: See CA5004B2M.ADA +-- +-- SPECIAL INSTRUCTIONS: See CA5004B2M.ADA +-- +-- TEST FILES: +-- CA5004B0.ADA +-- => CA5004B1.ADA +-- CA5004B2M.ADA + +-- PWN 05/31/96 Split test into files without duplicate unit names. +-- RLB 03/11/99 Split test into files so that units that will be replaced +-- and units that won't are not in the same source file. + +------------------------------------------------------------------ + +PACKAGE CA5004B0 IS + + I : INTEGER := 1; + + FUNCTION F RETURN BOOLEAN; + +END CA5004B0; + + +PACKAGE BODY CA5004B0 IS + + FUNCTION F RETURN BOOLEAN IS + BEGIN + RETURN TRUE; + END F; + +END CA5004B0; diff --git a/gcc/testsuite/ada/acats/tests/ca/ca5004b2.ada b/gcc/testsuite/ada/acats/tests/ca/ca5004b2.ada new file mode 100644 index 000000000..bae6280dc --- /dev/null +++ b/gcc/testsuite/ada/acats/tests/ca/ca5004b2.ada @@ -0,0 +1,153 @@ +-- CA5004B2M.ADA + +-- Grant of Unlimited Rights +-- +-- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687, +-- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained +-- unlimited rights in the software and documentation contained herein. +-- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making +-- this public release, the Government intends to confer upon all +-- recipients unlimited rights equal to those held by the Government. +-- These rights include rights to use, duplicate, release or disclose the +-- released technical data and computer software in whole or in part, in +-- any manner and for any purpose whatsoever, and to have or permit others +-- to do so. +-- +-- DISCLAIMER +-- +-- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR +-- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED +-- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF 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 PRAGMA ELABORATE IS ACCEPTED AND OBEYED EVEN IF THE UNIT +-- NAMED IN THE PRAGMA DOES NOT YET HAVE A BODY IN THE LIBRARY OR IF +-- ITS BODY IS OBSOLETE. +-- CHECK THAT MORE THAN ONE NAME IS ALLOWED IN A PRAGMA ELABORATE. +-- +-- SPECIAL INSTRUCTIONS: +-- 1. Compile CA5004B0.ADA +-- 2. Compile CA5004B1.ADA +-- 3. Compile CA5004B2M.ADA +-- 4. Bind/Link main unit CA5004B2M +-- 5. Execute the resulting file +-- +-- TEST FILES: +-- CA5004B0.ADA +-- CA5004B1.ADA +-- => CA5004B2M.ADA + +-- BHS 8/03/84 +-- JRK 9/20/84 +-- PWN 11/30/94 ADDED A PROCEDURE TO KEEP PACKAGE BODIES LEGAL. +-- PWN 05/31/96 Split test into files without duplicate unit names. +-- TMB 11/20/96 ADDED PROCEDURE DECL TO CA5004B0 TO INSURE IT MAKES +-- THE OLD BODY OBSOLETE +-- TMB 12/2/96 MADE NAME OF MAIN PROCEDURE SAME AS FILE NAME +-- RLB 03/11/99 Split first test file in order to prevent good units +-- from being made obsolete. + +------------------------------------------------------------- + +PACKAGE CA5004B0 IS -- OLD BODY NOW OBSOLETE. + + I : INTEGER := 2; + B : BOOLEAN := TRUE; + + FUNCTION F RETURN BOOLEAN; + PROCEDURE P; + +END CA5004B0; + +--------------------------------------------------------- + +PACKAGE CA5004B1 IS + + J : INTEGER := 3; + + PROCEDURE P (X : INTEGER); + +END CA5004B1; -- NO BODY GIVEN YET. + +---------------------------------------------------------- + +WITH HEADER; USE HEADER; +WITH CA5004B0, CA5004B1; +USE CA5004B0, CA5004B1; +PRAGMA ELABORATE (HEADER, CA5004B0, CA5004B1); +PACKAGE CA5004B2 IS + + K1 : INTEGER := CA5004B0.I; + K2 : INTEGER := CA5004B1.J; + + PROCEDURE REQUIRE_BODY; + +END CA5004B2; + + +PACKAGE BODY CA5004B2 IS + + PROCEDURE REQUIRE_BODY IS + BEGIN + NULL; + END; + +BEGIN + + IF K1 /= 4 THEN + WRONG ("OBSOLETE BODY"); + END IF; + + IF K2 /= 5 THEN + WRONG ("NO BODY"); + END IF; + +END CA5004B2; + +-------------------------------------------------- + +WITH REPORT, CA5004B2; +USE REPORT, CA5004B2; +PROCEDURE CA5004B2M IS +BEGIN + + RESULT; + +END CA5004B2M; + +---------------------------------------------------- + +PACKAGE BODY CA5004B0 IS + + FUNCTION F RETURN BOOLEAN IS + BEGIN + RETURN FALSE; + END F; + + PROCEDURE P IS + BEGIN + RETURN; + END P; + +BEGIN + + I := 4; + +END CA5004B0; + +--------------------------------------------------- + +PACKAGE BODY CA5004B1 IS + + PROCEDURE P (X : INTEGER) IS + BEGIN + NULL; + END P; + +BEGIN + + J := 5; + +END CA5004B1; diff --git a/gcc/testsuite/ada/acats/tests/ca/ca5006a.ada b/gcc/testsuite/ada/acats/tests/ca/ca5006a.ada new file mode 100644 index 000000000..cc4d3c9dd --- /dev/null +++ b/gcc/testsuite/ada/acats/tests/ca/ca5006a.ada @@ -0,0 +1,145 @@ +-- CA5006A.ADA + +-- Grant of Unlimited Rights +-- +-- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687, +-- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained +-- unlimited rights in the software and documentation contained herein. +-- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making +-- this public release, the Government intends to confer upon all +-- recipients unlimited rights equal to those held by the Government. +-- These rights include rights to use, duplicate, release or disclose the +-- released technical data and computer software in whole or in part, in +-- any manner and for any purpose whatsoever, and to have or permit others +-- to do so. +-- +-- DISCLAIMER +-- +-- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR +-- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED +-- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF 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 PROGRAM IS NOT REJECTED JUST BECAUSE THERE IS NO WAY TO +-- ELABORATE SECONDARY UNITS SO PROGRAM_ERROR WILL BE AVOIDED. + +-- R.WILLIAMS 9/22/86 + +----------------------------------------------------------------------- + +PACKAGE CA5006A0 IS + FUNCTION P_E_RAISED RETURN BOOLEAN; + PROCEDURE SHOW_PE_RAISED; +END CA5006A0; + +----------------------------------------------------------------------- + +WITH REPORT; USE REPORT; +PRAGMA ELABORATE (REPORT); +PACKAGE BODY CA5006A0 IS + RAISED : BOOLEAN := FALSE; + + FUNCTION P_E_RAISED RETURN BOOLEAN IS + BEGIN + RETURN RAISED; + END P_E_RAISED; + + PROCEDURE SHOW_PE_RAISED IS + BEGIN + RAISED := TRUE; + END SHOW_PE_RAISED; + +BEGIN + TEST ( "CA5006A", "CHECK THAT A PROGRAM IS NOT REJECTED JUST " & + "BECAUSE THERE IS NO WAY TO ELABORATE " & + "SECONDARY UNITS SO PROGRAM_ERROR WILL BE " & + "AVOIDED" ); + + +END CA5006A0; + +----------------------------------------------------------------------- + +PACKAGE CA5006A1 IS + FUNCTION F RETURN INTEGER; +END CA5006A1; + +----------------------------------------------------------------------- + +PACKAGE CA5006A2 IS + FUNCTION G RETURN INTEGER; +END CA5006A2; + +----------------------------------------------------------------------- + +WITH REPORT; USE REPORT; +WITH CA5006A0; USE CA5006A0; +WITH CA5006A2; USE CA5006A2; +PRAGMA ELABORATE(CA5006A0); + +PACKAGE BODY CA5006A1 IS + X : INTEGER; + + FUNCTION F RETURN INTEGER IS + BEGIN + RETURN IDENT_INT(0); + END F; + +BEGIN + X := G; + IF NOT P_E_RAISED THEN + FAILED ( "G CALLED" ); + END IF; +EXCEPTION + WHEN PROGRAM_ERROR => + COMMENT ( "PROGRAM_ERROR RAISED IN CA5006A1" ); + SHOW_PE_RAISED; + WHEN OTHERS => + FAILED ( "OTHER ERROR RAISED IN CA5006A1" ); +END CA5006A1; + +----------------------------------------------------------------------- + +WITH REPORT; USE REPORT; +WITH CA5006A0; USE CA5006A0; +WITH CA5006A1; USE CA5006A1; +PRAGMA ELABORATE(CA5006A0); + +PACKAGE BODY CA5006A2 IS + X : INTEGER; + + FUNCTION G RETURN INTEGER IS + BEGIN + RETURN IDENT_INT(1); + END G; + +BEGIN + X := F; + IF NOT P_E_RAISED THEN + FAILED ( "F CALLED" ); + END IF; +EXCEPTION + WHEN PROGRAM_ERROR => + COMMENT ( "PROGRAM_ERROR RAISED IN CA5006A2" ); + SHOW_PE_RAISED; + WHEN OTHERS => + FAILED ( "OTHER ERROR RAISED IN CA5006A2" ); +END CA5006A2; + +----------------------------------------------------------------------- + +WITH REPORT; USE REPORT; +WITH CA5006A0; USE CA5006A0; +WITH CA5006A1; +WITH CA5006A2; + +PROCEDURE CA5006A IS +BEGIN + IF NOT P_E_RAISED THEN + FAILED ( "PROGRAM_ERROR NEVER RAISED" ); + END IF; + + RESULT; +END CA5006A; |