summaryrefslogtreecommitdiff
path: root/gcc/testsuite/ada/acats/tests/cc/cc3017b.ada
diff options
context:
space:
mode:
Diffstat (limited to 'gcc/testsuite/ada/acats/tests/cc/cc3017b.ada')
-rw-r--r--gcc/testsuite/ada/acats/tests/cc/cc3017b.ada470
1 files changed, 470 insertions, 0 deletions
diff --git a/gcc/testsuite/ada/acats/tests/cc/cc3017b.ada b/gcc/testsuite/ada/acats/tests/cc/cc3017b.ada
new file mode 100644
index 000000000..0f8fcfd6f
--- /dev/null
+++ b/gcc/testsuite/ada/acats/tests/cc/cc3017b.ada
@@ -0,0 +1,470 @@
+-- CC3017B.ADA
+
+-- Grant of Unlimited Rights
+--
+-- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687,
+-- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained
+-- unlimited rights in the software and documentation contained herein.
+-- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making
+-- this public release, the Government intends to confer upon all
+-- recipients unlimited rights equal to those held by the Government.
+-- These rights include rights to use, duplicate, release or disclose the
+-- released technical data and computer software in whole or in part, in
+-- any manner and for any purpose whatsoever, and to have or permit others
+-- to do so.
+--
+-- DISCLAIMER
+--
+-- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR
+-- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED
+-- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE
+-- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE
+-- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A
+-- PARTICULAR PURPOSE OF SAID MATERIAL.
+--*
+-- CHECK THAT AN INSTANCE OF A GENERIC PROCEDURE MUST DECLARE A
+-- PROCEDURE AND THAT AN INSTANCE OF A GENERIC FUNCTION MUST
+-- DECLARE A FUNCTION. CHECK THAT CONSTRAINT_ERROR IS NOT RAISED
+-- IF THE DEFAULT VALUE FOR A FORMAL PARAMETER DOES NOT SATISFY
+-- THE CONSTRAINTS OF THE SUBTYPE_INDICATION WHEN THE
+-- DECLARATION IS ELABORATED, ONLY WHEN THE DEFAULT IS USED.
+
+-- SUBTESTS ARE:
+-- (A) ARRAY PARAMETERS CONSTRAINED WITH NONSTATIC BOUNDS AND
+-- INITIALIZED WITH A STATIC AGGREGATE.
+-- (B) A SCALAR PARAMETER WITH NON-STATIC RANGE CONSTRAINTS
+-- INITIALIZED WITH A STATIC VALUE.
+-- (C) A RECORD PARAMETER WHOSE COMPONENTS HAVE NON-STATIC
+-- CONSTRAINTS INITIALIZED WITH A STATIC AGGREGATE.
+-- (D) AN ARRAY PARAMETER CONSTRAINED WITH STATIC BOUNDS ON SUB-
+-- SCRIPTS AND NON-STATIC BOUNDS ON COMPONENTS, INITIALIZED
+-- WITH A STATIC AGGREGATE.
+-- (E) A RECORD PARAMETER WITH A NON-STATIC CONSTRAINT
+-- INITIALIZED WITH A STATIC AGGREGATE.
+
+-- EDWARD V. BERARD, 7 AUGUST 1990
+
+WITH REPORT;
+
+PROCEDURE CC3017B IS
+
+BEGIN
+
+ REPORT.TEST ("CC3017B", "CHECK THAT AN INSTANCE OF A GENERIC " &
+ "PROCEDURE MUST DECLARE A PROCEDURE AND THAT AN " &
+ "INSTANCE OF A GENERIC FUNCTION MUST DECLARE A " &
+ "FUNCTION. CHECK THAT CONSTRAINT_ERROR IS NOT " &
+ "RAISED IF AN INITIALIZATION VALUE DOES NOT SATISFY " &
+ "CONSTRAINTS ON A FORMAL PARAMETER");
+
+ --------------------------------------------------
+
+ NONSTAT_ARRAY_PARMS:
+
+ DECLARE
+
+-- (A) ARRAY PARAMETERS CONSTRAINED WITH NONSTATIC BOUNDS AND
+-- INITIALIZED WITH A STATIC AGGREGATE.
+
+ TYPE NUMBER IS RANGE 1 .. 100 ;
+
+ GENERIC
+
+ TYPE INTEGER_TYPE IS RANGE <> ;
+ LOWER : IN INTEGER_TYPE ;
+ UPPER : IN INTEGER_TYPE ;
+
+ PROCEDURE PA (FIRST : IN INTEGER_TYPE ;
+ SECOND : IN INTEGER_TYPE) ;
+
+ PROCEDURE PA (FIRST : IN INTEGER_TYPE ;
+ SECOND : IN INTEGER_TYPE) IS
+
+ TYPE A1 IS ARRAY (INTEGER_TYPE RANGE LOWER .. FIRST,
+ INTEGER_TYPE RANGE LOWER .. SECOND)
+ OF INTEGER_TYPE;
+
+ PROCEDURE PA1 (A : A1 := ((LOWER,UPPER),(UPPER,UPPER)))
+ IS
+ BEGIN
+ REPORT.FAILED ("BODY OF PA1 EXECUTED");
+ EXCEPTION
+ WHEN OTHERS =>
+ REPORT.FAILED ("EXCEPTION RAISED IN PA1");
+ END PA1;
+
+ BEGIN -- PA
+ PA1;
+ EXCEPTION
+ WHEN CONSTRAINT_ERROR =>
+ NULL;
+ WHEN OTHERS =>
+ REPORT.FAILED ("WRONG EXCEPTION RAISED - PA1");
+ END PA;
+
+ PROCEDURE NEW_PA IS NEW PA (INTEGER_TYPE => NUMBER,
+ LOWER => 1,
+ UPPER => 50) ;
+
+ BEGIN -- NONSTAT_ARRAY_PARMS
+
+ NEW_PA (FIRST => NUMBER (25),
+ SECOND => NUMBER (75));
+
+ EXCEPTION
+ WHEN OTHERS =>
+ REPORT.FAILED ("EXCEPTION RAISED IN CALL TO NEW_PA");
+
+ END NONSTAT_ARRAY_PARMS ;
+
+ --------------------------------------------------
+
+ SCALAR_NON_STATIC:
+
+ DECLARE
+
+-- (B) A SCALAR PARAMETER WITH NON-STATIC RANGE CONSTRAINTS
+-- INITIALIZED WITH A STATIC VALUE.
+
+ TYPE NUMBER IS RANGE 1 .. 100 ;
+
+ GENERIC
+
+ TYPE INTEGER_TYPE IS RANGE <> ;
+ STATIC_VALUE : IN INTEGER_TYPE ;
+
+ PROCEDURE PB (LOWER : IN INTEGER_TYPE ;
+ UPPER : IN INTEGER_TYPE) ;
+
+ PROCEDURE PB (LOWER : IN INTEGER_TYPE ;
+ UPPER : IN INTEGER_TYPE) IS
+
+ SUBTYPE INT IS INTEGER_TYPE RANGE LOWER .. UPPER ;
+
+ PROCEDURE PB1 (I : INT := STATIC_VALUE) IS
+ BEGIN -- PB1
+ REPORT.FAILED ("BODY OF PB1 EXECUTED");
+ EXCEPTION
+ WHEN OTHERS =>
+ REPORT.FAILED ("EXCEPTION RAISED IN PB1");
+ END PB1;
+
+ BEGIN -- PB
+ PB1;
+ EXCEPTION
+ WHEN CONSTRAINT_ERROR =>
+ NULL;
+ WHEN OTHERS =>
+ REPORT.FAILED ("WRONG EXCEPTION RAISED - PB1");
+ END PB;
+
+ PROCEDURE NEW_PB IS NEW PB (INTEGER_TYPE => NUMBER,
+ STATIC_VALUE => 20) ;
+
+ BEGIN -- SCALAR_NON_STATIC
+
+ NEW_PB (LOWER => NUMBER (25),
+ UPPER => NUMBER (75));
+
+ EXCEPTION
+ WHEN OTHERS =>
+ REPORT.FAILED ("EXCEPTION RAISED IN CALL TO NEW_PB");
+ END SCALAR_NON_STATIC ;
+
+ --------------------------------------------------
+
+ REC_NON_STAT_COMPS:
+
+ DECLARE
+
+-- (C) A RECORD PARAMETER WHOSE COMPONENTS HAVE NON-STATIC
+-- CONSTRAINTS INITIALIZED WITH A STATIC AGGREGATE.
+
+ TYPE NUMBER IS RANGE 1 .. 100 ;
+
+ GENERIC
+
+ TYPE INTEGER_TYPE IS RANGE <> ;
+ F_STATIC_VALUE : IN INTEGER_TYPE ;
+ S_STATIC_VALUE : IN INTEGER_TYPE ;
+ T_STATIC_VALUE : IN INTEGER_TYPE ;
+ L_STATIC_VALUE : IN INTEGER_TYPE ;
+
+ PROCEDURE PC (LOWER : IN INTEGER_TYPE ;
+ UPPER : IN INTEGER_TYPE) ;
+
+ PROCEDURE PC (LOWER : IN INTEGER_TYPE ;
+ UPPER : IN INTEGER_TYPE) IS
+
+ SUBTYPE SUBINTEGER_TYPE IS INTEGER_TYPE
+ RANGE LOWER .. UPPER ;
+ TYPE AR1 IS ARRAY (INTEGER RANGE 1..3) OF
+ SUBINTEGER_TYPE ;
+ TYPE REC IS
+ RECORD
+ FIRST : SUBINTEGER_TYPE ;
+ SECOND : AR1 ;
+ END RECORD;
+
+ PROCEDURE PC1 (R : REC := (F_STATIC_VALUE,
+ (S_STATIC_VALUE,
+ T_STATIC_VALUE,
+ L_STATIC_VALUE))) IS
+ BEGIN -- PC1
+ REPORT.FAILED ("BODY OF PC1 EXECUTED");
+ EXCEPTION
+ WHEN OTHERS =>
+ REPORT.FAILED ("EXCEPTION RAISED IN PC1");
+ END PC1;
+
+ BEGIN -- PC
+ PC1;
+ EXCEPTION
+ WHEN CONSTRAINT_ERROR =>
+ NULL;
+ WHEN OTHERS =>
+ REPORT.FAILED ("WRONG EXCEPTION RAISED - PC1");
+ END PC;
+
+ PROCEDURE NEW_PC IS NEW PC (INTEGER_TYPE => NUMBER,
+ F_STATIC_VALUE => 15,
+ S_STATIC_VALUE => 19,
+ T_STATIC_VALUE => 85,
+ L_STATIC_VALUE => 99) ;
+
+ BEGIN -- REC_NON_STAT_COMPS
+ NEW_PC (LOWER => 20,
+ UPPER => 80);
+ EXCEPTION
+ WHEN OTHERS =>
+ REPORT.FAILED ("EXCEPTION RAISED IN CALL TO NEW_PC");
+ END REC_NON_STAT_COMPS ;
+
+ --------------------------------------------------
+
+ FIRST_STATIC_ARRAY:
+
+ DECLARE
+
+-- (D) AN ARRAY PARAMETER CONSTRAINED WITH STATIC BOUNDS ON SUB-
+-- SCRIPTS AND NON-STATIC BOUNDS ON COMPONENTS, INITIALIZED
+-- WITH A STATIC AGGREGATE.
+
+ TYPE NUMBER IS RANGE 1 .. 100 ;
+
+ GENERIC
+
+ TYPE INTEGER_TYPE IS RANGE <> ;
+ F_STATIC_VALUE : IN INTEGER_TYPE ;
+ S_STATIC_VALUE : IN INTEGER_TYPE ;
+ T_STATIC_VALUE : IN INTEGER_TYPE ;
+ L_STATIC_VALUE : IN INTEGER_TYPE ;
+ A_STATIC_VALUE : IN INTEGER_TYPE ;
+ B_STATIC_VALUE : IN INTEGER_TYPE ;
+ C_STATIC_VALUE : IN INTEGER_TYPE ;
+ D_STATIC_VALUE : IN INTEGER_TYPE ;
+
+ PROCEDURE P1D (LOWER : IN INTEGER_TYPE ;
+ UPPER : IN INTEGER_TYPE) ;
+
+ PROCEDURE P1D (LOWER : IN INTEGER_TYPE ;
+ UPPER : IN INTEGER_TYPE) IS
+
+ SUBTYPE SUBINTEGER_TYPE IS INTEGER_TYPE
+ RANGE LOWER .. UPPER ;
+
+ TYPE A1 IS ARRAY (INTEGER_TYPE RANGE
+ F_STATIC_VALUE .. S_STATIC_VALUE,
+ INTEGER_TYPE RANGE
+ T_STATIC_VALUE .. L_STATIC_VALUE)
+ OF SUBINTEGER_TYPE ;
+
+ PROCEDURE P1D1 (A : A1 :=
+ ((A_STATIC_VALUE, B_STATIC_VALUE),
+ (C_STATIC_VALUE, D_STATIC_VALUE))) IS
+ BEGIN -- P1D1
+ REPORT.FAILED ("BODY OF P1D1 EXECUTED");
+ EXCEPTION
+ WHEN OTHERS =>
+ REPORT.FAILED ("EXCEPTION RAISED IN P1D1");
+ END P1D1;
+
+ BEGIN -- P1D
+ P1D1 ;
+ EXCEPTION
+ WHEN CONSTRAINT_ERROR =>
+ NULL;
+ WHEN OTHERS =>
+ REPORT.FAILED ("WRONG EXCEPTION RAISED - P1D1");
+ END P1D;
+
+ PROCEDURE NEW_P1D IS NEW P1D (INTEGER_TYPE => NUMBER,
+ F_STATIC_VALUE => 21,
+ S_STATIC_VALUE => 37,
+ T_STATIC_VALUE => 67,
+ L_STATIC_VALUE => 79,
+ A_STATIC_VALUE => 11,
+ B_STATIC_VALUE => 88,
+ C_STATIC_VALUE => 87,
+ D_STATIC_VALUE => 13) ;
+
+ BEGIN -- FIRST_STATIC_ARRAY
+ NEW_P1D (LOWER => 10,
+ UPPER => 90);
+ EXCEPTION
+ WHEN OTHERS =>
+ REPORT.FAILED ("EXCEPTION RAISED IN CALL TO NEW_P1D");
+ END FIRST_STATIC_ARRAY ;
+
+ --------------------------------------------------
+
+ SECOND_STATIC_ARRAY:
+
+ DECLARE
+
+-- (D) AN ARRAY PARAMETER CONSTRAINED WITH STATIC BOUNDS ON SUB-
+-- SCRIPTS AND NON-STATIC BOUNDS ON COMPONENTS, INITIALIZED
+-- WITH A STATIC AGGREGATE.
+
+ TYPE NUMBER IS RANGE 1 .. 100 ;
+
+ GENERIC
+
+ TYPE INTEGER_TYPE IS RANGE <> ;
+ F_STATIC_VALUE : IN INTEGER_TYPE ;
+ S_STATIC_VALUE : IN INTEGER_TYPE ;
+ T_STATIC_VALUE : IN INTEGER_TYPE ;
+ L_STATIC_VALUE : IN INTEGER_TYPE ;
+ A_STATIC_VALUE : IN INTEGER_TYPE ;
+ B_STATIC_VALUE : IN INTEGER_TYPE ;
+
+ PROCEDURE P2D (LOWER : IN INTEGER_TYPE ;
+ UPPER : IN INTEGER_TYPE) ;
+
+ PROCEDURE P2D (LOWER : IN INTEGER_TYPE ;
+ UPPER : IN INTEGER_TYPE) IS
+
+ SUBTYPE SUBINTEGER_TYPE IS INTEGER_TYPE
+ RANGE LOWER .. UPPER ;
+
+ TYPE A1 IS ARRAY (INTEGER_TYPE RANGE
+ F_STATIC_VALUE .. S_STATIC_VALUE,
+ INTEGER_TYPE RANGE
+ T_STATIC_VALUE .. L_STATIC_VALUE)
+ OF SUBINTEGER_TYPE ;
+
+ PROCEDURE P2D1 (A : A1 :=
+ (F_STATIC_VALUE .. S_STATIC_VALUE =>
+ (A_STATIC_VALUE, B_STATIC_VALUE))) IS
+ BEGIN -- P2D1
+ REPORT.FAILED ("BODY OF P2D1 EXECUTED");
+ EXCEPTION
+ WHEN OTHERS =>
+ REPORT.FAILED ("EXCEPTION RAISED IN P2D1");
+ END P2D1;
+
+ BEGIN -- P2D
+ P2D1;
+ EXCEPTION
+ WHEN CONSTRAINT_ERROR =>
+ NULL;
+ WHEN OTHERS =>
+ REPORT.FAILED ("WRONG EXCEPTION RAISED - P2D1");
+ END P2D;
+
+ PROCEDURE NEW_P2D IS NEW P2D (INTEGER_TYPE => NUMBER,
+ F_STATIC_VALUE => 21,
+ S_STATIC_VALUE => 37,
+ T_STATIC_VALUE => 67,
+ L_STATIC_VALUE => 79,
+ A_STATIC_VALUE => 7,
+ B_STATIC_VALUE => 93) ;
+
+ BEGIN -- SECOND_STATIC_ARRAY
+ NEW_P2D (LOWER => 5,
+ UPPER => 95);
+ EXCEPTION
+ WHEN OTHERS =>
+ REPORT.FAILED ("EXCEPTION RAISED IN CALL TO NEW_P2D");
+ END SECOND_STATIC_ARRAY ;
+
+ --------------------------------------------------
+
+ REC_NON_STATIC_CONS:
+
+ DECLARE
+
+-- (E) A RECORD PARAMETER WITH A NON-STATIC CONSTRAINT
+-- INITIALIZED WITH A STATIC AGGREGATE.
+
+ TYPE NUMBER IS RANGE 1 .. 100 ;
+
+ GENERIC
+
+ TYPE INTEGER_TYPE IS RANGE <> ;
+ F_STATIC_VALUE : IN INTEGER_TYPE ;
+ S_STATIC_VALUE : IN INTEGER_TYPE ;
+ T_STATIC_VALUE : IN INTEGER_TYPE ;
+ L_STATIC_VALUE : IN INTEGER_TYPE ;
+ D_STATIC_VALUE : IN INTEGER_TYPE ;
+
+ PROCEDURE PE (LOWER : IN INTEGER_TYPE ;
+ UPPER : IN INTEGER_TYPE) ;
+
+ PROCEDURE PE (LOWER : IN INTEGER_TYPE ;
+ UPPER : IN INTEGER_TYPE) IS
+
+ SUBTYPE SUBINTEGER_TYPE IS INTEGER_TYPE
+ RANGE LOWER .. UPPER ;
+ TYPE AR1 IS ARRAY (INTEGER RANGE 1..3) OF
+ SUBINTEGER_TYPE ;
+
+ TYPE REC (DISCRIM : SUBINTEGER_TYPE) IS
+ RECORD
+ FIRST : SUBINTEGER_TYPE ;
+ SECOND : AR1 ;
+ END RECORD ;
+
+ SUBTYPE REC4 IS REC (LOWER) ;
+
+ PROCEDURE PE1 (R : REC4 := (D_STATIC_VALUE,
+ F_STATIC_VALUE,
+ (S_STATIC_VALUE,
+ T_STATIC_VALUE,
+ L_STATIC_VALUE))) IS
+ BEGIN -- PE1
+ REPORT.FAILED ("BODY OF PE1 EXECUTED");
+ EXCEPTION
+ WHEN OTHERS =>
+ REPORT.FAILED ("EXCEPTION RAISED IN PE1");
+ END PE1;
+
+ BEGIN -- PE
+ PE1;
+ EXCEPTION
+ WHEN CONSTRAINT_ERROR =>
+ NULL;
+ WHEN OTHERS =>
+ REPORT.FAILED ("WRONG EXCEPTION RAISED - PE1");
+ END PE;
+
+ PROCEDURE NEW_PE IS NEW PE (INTEGER_TYPE => NUMBER,
+ F_STATIC_VALUE => 37,
+ S_STATIC_VALUE => 21,
+ T_STATIC_VALUE => 67,
+ L_STATIC_VALUE => 79,
+ D_STATIC_VALUE => 44) ;
+
+ BEGIN -- REC_NON_STATIC_CONS
+ NEW_PE (LOWER => 2,
+ UPPER => 99);
+ EXCEPTION
+ WHEN OTHERS =>
+ REPORT.FAILED ("EXCEPTION RAISED IN CALL TO NEW_PE");
+ END REC_NON_STATIC_CONS ;
+
+ --------------------------------------------------
+
+ REPORT.RESULT;
+
+END CC3017B;
generated by cgit v1.2.3 (git 2.25.1) at 2025-04-21 22:52:27 +0000