diff options
Diffstat (limited to 'gcc/testsuite/ada/acats/tests/c5')
95 files changed, 15510 insertions, 0 deletions
diff --git a/gcc/testsuite/ada/acats/tests/c5/c51004a.ada b/gcc/testsuite/ada/acats/tests/c5/c51004a.ada new file mode 100644 index 000000000..75fa271d0 --- /dev/null +++ b/gcc/testsuite/ada/acats/tests/c5/c51004a.ada @@ -0,0 +1,261 @@ +-- C51004A.ADA + +-- Grant of Unlimited Rights +-- +-- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687, +-- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained +-- unlimited rights in the software and documentation contained herein. +-- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making +-- this public release, the Government intends to confer upon all +-- recipients unlimited rights equal to those held by the Government. +-- These rights include rights to use, duplicate, release or disclose the +-- released technical data and computer software in whole or in part, in +-- any manner and for any purpose whatsoever, and to have or permit others +-- to do so. +-- +-- DISCLAIMER +-- +-- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR +-- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED +-- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF 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 LABELS, LOOP IDENTIFIERS, AND BLOCK IDENTIFIERS ARE +-- IMPLICITLY DECLARED AT THE END OF THE DECLARATIVE PART. PRIOR TO +-- THE END OF THE DECLARATIVE PART, THEY MAY BE USED TO REFERENCE +-- ENTITIES IN AN ENCLOSING SCOPE. SUBTESTS ARE: +-- (A) BLOCK. +-- (B) PROCEDURE BODY. +-- (C) PACKAGE BODY. +-- (D) GENERIC FUNCTION BODY. +-- (E) GENERIC PACKAGE BODY. +-- (F) TASK BODY. + +-- CPP 6/1/84 + +WITH REPORT; USE REPORT; +PROCEDURE C51004A IS + +BEGIN + TEST("C51004A", "CHECK THAT LABELS, LOOP IDENTIFIERS, AND BLOCK " & + "IDENTIFIERS MAY BE USED PRIOR TO THEIR IMPLICIT " & + "DECLARATION"); + +OUTER: DECLARE + + TYPE IDN1 IS NEW INTEGER; + IDN2 : CONSTANT INTEGER := 2; + TYPE IDN3 IS ACCESS INTEGER; + + BEGIN -- OUTER + + ----------------------------------------------- + + A : DECLARE + + A1 : IDN1; + A2 : CONSTANT INTEGER := IDN2; + A3 : IDN3; + + TEMP : INTEGER; + + BEGIN -- A + + <<IDN1>> TEMP := 0; + + IDN2 : FOR I IN 1..1 LOOP + TEMP := A2; + END LOOP IDN2; + + IDN3 : BEGIN + NULL; + END IDN3; + + END A; + + ----------------------------------------------- + + B : DECLARE + + PROCEDURE P (TEMP : OUT INTEGER) IS + + B1 : IDN1; + B2 : CONSTANT INTEGER := IDN2 + 2; + B3 : IDN3; + + BEGIN -- P + + <<L>> <<IDN1>> TEMP := 0; + + IDN2 : WHILE B2 < 0 LOOP + TEMP := 0; + END LOOP IDN2; + + IDN3 : DECLARE + BEGIN + NULL; + END IDN3; + + END P; + + BEGIN -- B + NULL; + END B; + + ----------------------------------------------- + + C : DECLARE + + PACKAGE PKG IS + END PKG; + + PACKAGE BODY PKG IS + + C1 : IDN1; + C2 : CONSTANT INTEGER := 2 * IDN2; + C3 : IDN3; + + TEMP : INTEGER; + + BEGIN + + <<IDN1>> TEMP := 0; + + IDN2 : LOOP + TEMP := 0; + EXIT; + END LOOP IDN2; + + IDN3 : BEGIN + NULL; + END IDN3; + + END PKG; + + BEGIN -- C + NULL; + END C; + + --------------------------------------------------- + + D : DECLARE + + GENERIC + TYPE Q IS (<>); + FUNCTION FN RETURN INTEGER; + + FUNCTION FN RETURN INTEGER IS + + D1 : IDN1; + D2 : CONSTANT INTEGER := IDN2; + D3 : IDN3; + + TEMP : INTEGER; + + BEGIN + + <<IDN1>> TEMP := 0; + + IDN2 : FOR I IN 1..5 LOOP + TEMP := 0; + END LOOP IDN2; + + IDN3 : BEGIN + NULL; + END IDN3; + + RETURN TEMP; + + END FN; + + BEGIN + NULL; + END D; + + ----------------------------------------------- + + E : DECLARE + + GENERIC + + TYPE ELEMENT IS (<>); + ITEM : ELEMENT; + + PACKAGE PKG IS + END PKG; + + PACKAGE BODY PKG IS + + E1 : IDN1 RANGE 1..5; + E2 : CONSTANT INTEGER := IDN2; + E3 : IDN3; + + TEMP : ELEMENT; + + BEGIN + + <<IDN1>> <<L>> TEMP := ITEM; + + IDN2 : WHILE TEMP /= ITEM LOOP + TEMP := ITEM; + END LOOP IDN2; + + IDN3 : DECLARE + BEGIN + NULL; + END IDN3; + + END PKG; + + BEGIN -- E + + DECLARE + PACKAGE P1 IS NEW PKG (INTEGER, 0); + BEGIN + NULL; + END; + + END E; + + ----------------------------------------------- + + F : DECLARE + + TASK T; + + TASK BODY T IS + + F1 : IDN1 RANGE -4..2; + F2 : CONSTANT INTEGER := IDN2; + F3 : IDN3; + + TEMP : INTEGER; + + BEGIN + + <<IDN1>> TEMP := 1; + + IDN2 : LOOP + TEMP := TEMP + 1; + EXIT; + END LOOP IDN2; + + IDN3 : DECLARE + BEGIN + TEMP := TEMP + 1; + END IDN3; + + END T; + + BEGIN -- F + NULL; + END F; + + ----------------------------------------------- + + END OUTER; + + RESULT; +END C51004A; diff --git a/gcc/testsuite/ada/acats/tests/c5/c52005a.ada b/gcc/testsuite/ada/acats/tests/c5/c52005a.ada new file mode 100644 index 000000000..2c70049c8 --- /dev/null +++ b/gcc/testsuite/ada/acats/tests/c5/c52005a.ada @@ -0,0 +1,177 @@ +-- C52005A.ADA + +-- Grant of Unlimited Rights +-- +-- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687, +-- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained +-- unlimited rights in the software and documentation contained herein. +-- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making +-- this public release, the Government intends to confer upon all +-- recipients unlimited rights equal to those held by the Government. +-- These rights include rights to use, duplicate, release or disclose the +-- released technical data and computer software in whole or in part, in +-- any manner and for any purpose whatsoever, and to have or permit others +-- to do so. +-- +-- DISCLAIMER +-- +-- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR +-- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED +-- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF 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 CONSTRAINT_ERROR EXCEPTION IS RAISED WHEN A STATIC +-- EXPRESSION VALUE IS OUTSIDE THE STATIC RANGE OF INTEGER, BOOLEAN, +-- CHARACTER, AND ENUMERATION ASSIGNMENT TARGET VARIABLES. + +-- DCB 2/5/80 +-- JRK 7/21/80 +-- SPS 3/21/83 + +WITH REPORT; +PROCEDURE C52005A IS + + USE REPORT; + +BEGIN + TEST ("C52005A", "CHECK THAT CONSTRAINT_ERROR EXCEPTION IS RAISED " + & "ON STATIC OUT OF RANGE INTEGER, BOOLEAN, CHARACTER, " & + "AND ENUMERATION ASSIGNMENTS"); + +------------------------- + + DECLARE + I1 : INTEGER RANGE 0..10 := 5; + + BEGIN + I1 := 11; + + FAILED ("EXCEPTION NOT RAISED FOR OUT OF RANGE INT ASSNMT"); + + EXCEPTION + WHEN CONSTRAINT_ERROR => + IF I1 /= 5 THEN + FAILED ("VALUE ALTERED BEFORE INT RANGE" & + "EXCEPTION"); + END IF; + + END; + +------------------------- + + DECLARE + I2 : INTEGER RANGE 0..10 := 5; + + BEGIN + I2 := 10; + + EXCEPTION + WHEN CONSTRAINT_ERROR => + FAILED ("EXCEPTION RAISED ON LEGAL INTEGER ASSIGNMENT"); + END; + +------------------------- + + DECLARE + B1 : BOOLEAN RANGE TRUE..TRUE := TRUE; + + BEGIN + B1 := FALSE; + + FAILED ("EXCEPTION NOT RAISED FOR OUT OF RANGE BOOL ASSNMT"); + + EXCEPTION + WHEN CONSTRAINT_ERROR => + IF B1 /= TRUE THEN + FAILED ("VALUE ALTERED BEFORE BOOLEAN RANGE EXCEPTION"); + END IF; + END; + +------------------------- + + DECLARE + B2 : BOOLEAN := TRUE; + + BEGIN + B2 := FALSE; + + EXCEPTION + WHEN CONSTRAINT_ERROR => + FAILED ("EXCEPTION RAISED ON LEGAL BOOLEAN ASSNMNT"); + + END; + +------------------------- + + DECLARE + C1 : CHARACTER RANGE 'B'..'Z' := 'M'; + + BEGIN + C1 := 'A'; + + FAILED ("EXCEPTION NOT RAISED FOR OUT OF RANGE CHAR ASSNMNT"); + + EXCEPTION + WHEN CONSTRAINT_ERROR => + IF C1 /= 'M' THEN + FAILED ("VALUE ALTERED BEFORE CHARACTER RANGE " & + "EXCEPTION"); + END IF; + + END; + +------------------------- + + DECLARE + C2 : CHARACTER RANGE 'B'..'Z' := 'M'; + + BEGIN + C2 := 'B'; + + EXCEPTION + WHEN CONSTRAINT_ERROR => + FAILED ("EXCEPTION RAISED OF LEGAL CHARACTER ASSNMNT"); + + END; + +------------------------- + + DECLARE + TYPE DAY IS (SUN, MON, TUE, WED, THU, FRI, SAT); + WORKDAY : DAY RANGE MON..FRI := TUE; + + BEGIN + WORKDAY := SUN; + + FAILED ("EXCEPTION NOT RAISED FOR OUT OF RANGE ENUM. " & + "ASSIGNMENT"); + + EXCEPTION + WHEN CONSTRAINT_ERROR => + IF WORKDAY /= TUE THEN + FAILED ("VALUE ALTERED BEFORE ENUM. RANGE EXCEPTION"); + END IF; + + END; + +------------------------- + + DECLARE + TYPE DAY IS (SUN, MON, TUE, WED, THU, FRI, SAT); + WORKDAY : DAY RANGE MON..FRI := TUE; + + BEGIN + WORKDAY := FRI; + + EXCEPTION + WHEN CONSTRAINT_ERROR => + FAILED ("EXCEPTION RAISED ON LEGAL ENUM. ASSNMNT"); + + END; + +------------------------- + + RESULT; +END C52005A; diff --git a/gcc/testsuite/ada/acats/tests/c5/c52005b.ada b/gcc/testsuite/ada/acats/tests/c5/c52005b.ada new file mode 100644 index 000000000..94b55be7f --- /dev/null +++ b/gcc/testsuite/ada/acats/tests/c5/c52005b.ada @@ -0,0 +1,115 @@ +-- C52005B.ADA + +-- Grant of Unlimited Rights +-- +-- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687, +-- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained +-- unlimited rights in the software and documentation contained herein. +-- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making +-- this public release, the Government intends to confer upon all +-- recipients unlimited rights equal to those held by the Government. +-- These rights include rights to use, duplicate, release or disclose the +-- released technical data and computer software in whole or in part, in +-- any manner and for any purpose whatsoever, and to have or permit others +-- to do so. +-- +-- DISCLAIMER +-- +-- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR +-- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED +-- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF 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 CONSTRAINT_ERROR EXCEPTION IS RAISED +-- WHEN A STATIC EXPRESSION VALUE IS OUTSIDE THE STATIC RANGE +-- OF FLOATING POINT ASSIGNMENTS. + +-- DCB 2/6/80 +-- JRK 7/21/80 +-- SPS 3/21/83 + +WITH REPORT; +PROCEDURE C52005B IS + + USE REPORT; + +BEGIN + TEST ("C52005B", "CHECK THAT CONSTRAINT_ERROR EXCEPTION IS RAISED" + & " ON STATIC OUT OF RANGE FLOATING POINT ASSIGNMENTS"); + +------------------------- + + DECLARE + TYPE FLT IS DIGITS 3 RANGE 0.0 .. 5.0E2; + FL1 : FLT RANGE 0.0 .. 100.0 := 50.0; + + BEGIN + FL1 := 101.0; + + FAILED ("EXCEPTION NOT RAISED FOR OUT OF RANGE FLT1 PT " & + "ASSIGNMENT"); + + EXCEPTION + WHEN CONSTRAINT_ERROR => + IF FL1 /= 50.0 THEN + FAILED ("VALUE ALTERED BEFORE FLT1 PT RANGE EXCEPTION"); + END IF; + + END; + +------------------------- + + DECLARE + TYPE FLT IS DIGITS 3 RANGE 0.0 .. 5.0E2; + FL2 : FLT RANGE 0.0 .. 100.0 := 50.0; + + + BEGIN + FL2 := 100.0; + + EXCEPTION + WHEN CONSTRAINT_ERROR => + FAILED ("EXCEPTION RAISED ON LEGAL FLOATING1 PT" & + "ASSIGNMENT"); + + END; + +------------------------- + + DECLARE + FL1 : FLOAT RANGE 0.0 .. 100.0 := 50.0; + + BEGIN + FL1 := -0.001; + + FAILED ("EXCEPTION NOT RAISED FOR OUT OF RANGE FLTG PT " & + "ASSIGNMENT"); + + EXCEPTION + WHEN CONSTRAINT_ERROR => + IF FL1 /= 50.0 THEN + FAILED ("VALUE ALTERED BEFORE FLTG PT RANGE EXCEPTION"); + END IF; + + END; + +------------------------- + + DECLARE + FL2 : FLOAT RANGE 0.0 .. 100.0 := 50.0; + + BEGIN + FL2 := 0.0; + + EXCEPTION + WHEN CONSTRAINT_ERROR => + FAILED ("EXCEPTION RAISED ON LEGAL FLOATING PT ASSNMT"); + + END; + +---------------------- + + RESULT; +END C52005B; diff --git a/gcc/testsuite/ada/acats/tests/c5/c52005c.ada b/gcc/testsuite/ada/acats/tests/c5/c52005c.ada new file mode 100644 index 000000000..e064e5ca7 --- /dev/null +++ b/gcc/testsuite/ada/acats/tests/c5/c52005c.ada @@ -0,0 +1,79 @@ +-- C52005C.ADA + +-- Grant of Unlimited Rights +-- +-- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687, +-- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained +-- unlimited rights in the software and documentation contained herein. +-- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making +-- this public release, the Government intends to confer upon all +-- recipients unlimited rights equal to those held by the Government. +-- These rights include rights to use, duplicate, release or disclose the +-- released technical data and computer software in whole or in part, in +-- any manner and for any purpose whatsoever, and to have or permit others +-- to do so. +-- +-- DISCLAIMER +-- +-- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR +-- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED +-- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF 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 CONSTRAINT_ERROR EXCEPTION IS RAISED +-- WHEN A STATIC EXPRESSION VALUE IS OUTSIDE THE STATIC RANGE +-- OF FIXED POINT ASSIGNMENTS. + +-- DCB 2/6/80 +-- JRK 7/21/80 +-- SPS 3/21/83 + +WITH REPORT; +PROCEDURE C52005C IS + + USE REPORT; + +BEGIN + TEST ("C52005C", "CHECK THAT CONSTRAINT_ERROR EXCEPTION IS RAISED" + & " ON STATIC OUT OF RANGE FIXED POINT ASSIGNMENTS"); + +----------------------- + + DECLARE + TYPE REAL IS DELTA 0.01 RANGE 0.00 .. 9.99; + FX1 : REAL RANGE 0.00 .. 7.00 := 4.50; + + BEGIN + FX1 := 7.01; + + FAILED ("EXCEPTION NOT RAISED FOR OUT OF RANGE FIXED ASSNMT"); + + EXCEPTION + WHEN CONSTRAINT_ERROR => + IF FX1 /= 4.50 THEN + FAILED ("VALUE ALTERED BEFORE FIXED PT RANGE EXCEPTION"); + END IF; + + END; + +------------------------- + + DECLARE + TYPE REAL IS DELTA 0.01 RANGE 0.00 .. 9.99; + FX2 : REAL RANGE 0.00 .. 7.00 := 4.50; + + BEGIN + FX2 := 7.00; + + EXCEPTION + WHEN CONSTRAINT_ERROR => + FAILED ("EXCEPTION RAISED ON LEGAL FIXED PT ASSNMT"); + + END; + +------------------------- + + RESULT; +END C52005C; diff --git a/gcc/testsuite/ada/acats/tests/c5/c52005d.ada b/gcc/testsuite/ada/acats/tests/c5/c52005d.ada new file mode 100644 index 000000000..055482b9f --- /dev/null +++ b/gcc/testsuite/ada/acats/tests/c5/c52005d.ada @@ -0,0 +1,182 @@ +-- C52005D.ADA + +-- Grant of Unlimited Rights +-- +-- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687, +-- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained +-- unlimited rights in the software and documentation contained herein. +-- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making +-- this public release, the Government intends to confer upon all +-- recipients unlimited rights equal to those held by the Government. +-- These rights include rights to use, duplicate, release or disclose the +-- released technical data and computer software in whole or in part, in +-- any manner and for any purpose whatsoever, and to have or permit others +-- to do so. +-- +-- DISCLAIMER +-- +-- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR +-- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED +-- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF 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 CONSTRAINT_ERROR EXCEPTION IS RAISED WHEN A DYNAMIC +-- EXPRESSION VALUE IS OUTSIDE THE STATIC RANGE OF INTEGER, BOOLEAN, +-- CHARACTER, AND ENUMERATION ASSIGNMENT TARGET VARIABLES. + +-- JRK 7/21/80 +-- SPS 3/21/83 + +WITH REPORT; +PROCEDURE C52005D IS + + USE REPORT; + +BEGIN + TEST ("C52005D", "CHECK THAT CONSTRAINT_ERROR EXCEPTION IS RAISED " + & "ON DYNAMIC OUT OF RANGE INTEGER, BOOLEAN, CHARACTER, " & + "AND ENUMERATION ASSIGNMENTS"); + +------------------------- + + DECLARE + I1 : INTEGER RANGE 0..10 := 5; + + BEGIN + I1 := IDENT_INT(11); + + FAILED ("EXCEPTION NOT RAISED FOR OUT OF RANGE INT ASSNMT"); + + EXCEPTION + WHEN CONSTRAINT_ERROR => + IF I1 /= 5 THEN + FAILED ("VALUE ALTERED BEFORE INT RANGE EXCEPTION"); + END IF; + + END; + +------------------------- + + DECLARE + I2 : INTEGER RANGE 0..10 := 5; + + BEGIN + I2 := IDENT_INT(10); + + EXCEPTION + WHEN CONSTRAINT_ERROR => + FAILED ("EXCEPTION RAISED ON LEGAL INTEGER ASSIGNMENT"); + END; + +------------------------- + + DECLARE + B1 : BOOLEAN RANGE TRUE..TRUE := TRUE; + + BEGIN + B1 := IDENT_BOOL(FALSE); + + FAILED ("EXCEPTION NOT RAISED FOR OUT OF RANGE BOOL ASSNMT"); + + EXCEPTION + WHEN CONSTRAINT_ERROR => + IF B1 /= TRUE THEN + FAILED ("VALUE ALTERED BEFORE BOOLEAN RANGE EXCEPTION"); + END IF; + END; + +------------------------- + + DECLARE + B2 : BOOLEAN := TRUE; + + BEGIN + B2 := IDENT_BOOL(FALSE); + + EXCEPTION + WHEN CONSTRAINT_ERROR => + FAILED ("EXCEPTION RAISED ON LEGAL BOOLEAN ASSNMNT"); + + END; + +------------------------- + + DECLARE + C1 : CHARACTER RANGE 'B'..'Z' := 'M'; + + BEGIN + C1 := IDENT_CHAR('A'); + FAILED ("EXCEPTION NOT RAISED FOR OUT OF RANGE CHAR ASSNMNT"); + + EXCEPTION + WHEN CONSTRAINT_ERROR => + IF C1 /= 'M' THEN + FAILED ("VALUE ALTERED BEFORE CHARACTER RANGE " & + "EXCEPTION"); + END IF; + + END; + +------------------------- + + DECLARE + C2 : CHARACTER RANGE 'B'..'Z' := 'M'; + + BEGIN + C2 := IDENT_CHAR('B'); + + EXCEPTION + WHEN CONSTRAINT_ERROR => + FAILED ("EXCEPTION RAISED OF LEGAL CHARACTER ASSNMNT"); + + END; + +------------------------- + + DECLARE + TYPE DAY IS (SUN, MON, TUE, WED, THU, FRI, SAT); + ALLDAYS : DAY := TUE; + WORKDAY : DAY RANGE MON..FRI := TUE; + + BEGIN + IF EQUAL(3,3) THEN + ALLDAYS := SUN; + END IF; + WORKDAY := ALLDAYS; + + FAILED ("EXCEPTION NOT RAISED FOR OUT OF RANGE ENUM. " & + "ASSIGNMENT"); + + EXCEPTION + WHEN CONSTRAINT_ERROR => + IF WORKDAY /= TUE THEN + FAILED ("VALUE ALTERED BEFORE ENUM. RANGE EXCEPTION"); + END IF; + + END; + +------------------------- + + DECLARE + TYPE DAY IS (SUN, MON, TUE, WED, THU, FRI, SAT); + ALLDAYS : DAY := TUE; + WORKDAY : DAY RANGE MON..FRI := TUE; + + BEGIN + IF EQUAL(3,3) THEN + ALLDAYS := FRI; + END IF; + WORKDAY := ALLDAYS; + + EXCEPTION + WHEN CONSTRAINT_ERROR => + FAILED ("EXCEPTION RAISED ON LEGAL ENUM. ASSNMNT"); + + END; + +------------------------- + + RESULT; +END C52005D; diff --git a/gcc/testsuite/ada/acats/tests/c5/c52005e.ada b/gcc/testsuite/ada/acats/tests/c5/c52005e.ada new file mode 100644 index 000000000..c474e21e9 --- /dev/null +++ b/gcc/testsuite/ada/acats/tests/c5/c52005e.ada @@ -0,0 +1,129 @@ +-- C52005E.ADA + +-- Grant of Unlimited Rights +-- +-- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687, +-- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained +-- unlimited rights in the software and documentation contained herein. +-- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making +-- this public release, the Government intends to confer upon all +-- recipients unlimited rights equal to those held by the Government. +-- These rights include rights to use, duplicate, release or disclose the +-- released technical data and computer software in whole or in part, in +-- any manner and for any purpose whatsoever, and to have or permit others +-- to do so. +-- +-- DISCLAIMER +-- +-- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR +-- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED +-- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF 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 CONSTRAINT_ERROR EXCEPTION IS RAISED +-- WHEN A DYNAMIC EXPRESSION VALUE IS OUTSIDE THE STATIC RANGE +-- OF FLOATING POINT ASSIGNMENTS. + +-- JRK 7/21/80 +-- SPS 3/21/83 + +WITH REPORT; +PROCEDURE C52005E IS + + USE REPORT; + +BEGIN + TEST ("C52005E", "CHECK THAT CONSTRAINT_ERROR EXCEPTION IS RAISED" + & " ON DYNAMIC OUT OF RANGE FLOATING POINT ASSIGNMENTS"); + +------------------------- + + DECLARE + TYPE FLT IS DIGITS 3 RANGE 0.0 .. 5.0E2; + FL : FLT := 50.0; + FL1 : FLT RANGE 0.0 .. 100.0 := 50.0; + + BEGIN + IF EQUAL(3,3) THEN + FL := 101.0; + END IF; + FL1 := FL; + + FAILED ("EXCEPTION NOT RAISED FOR OUT OF RANGE FLT1 PT " & + "ASSIGNMENT"); + + EXCEPTION + WHEN CONSTRAINT_ERROR => + IF FL1 /= 50.0 THEN + FAILED ("VALUE ALTERED BEFORE FLT1 PT RANGE EXCEPTION"); + END IF; + + END; + +------------------------- + + DECLARE + TYPE FLT IS DIGITS 3 RANGE 0.0 .. 5.0E2; + FL : FLT := 50.0; + FL2 : FLT RANGE 0.0 .. 100.0 := 50.0; + + + BEGIN + IF EQUAL(3,3) THEN + FL := 100.0; + END IF; + FL2 := FL; + + EXCEPTION + WHEN CONSTRAINT_ERROR => + FAILED ("EXCEPTION RAISED ON LEGAL FLOATING1 PT ASSNMT"); + + END; + +------------------------- + + DECLARE + FL : FLOAT := 50.0; + FL1 : FLOAT RANGE 0.0 .. 100.0 := 50.0; + + BEGIN + IF EQUAL(3,3) THEN + FL := -0.001; + END IF; + FL1 := FL; + + FAILED ("EXCEPTION NOT RAISED FOR OUT OF RANGE FLTG PT " & + "ASSIGNMENT"); + + EXCEPTION + WHEN CONSTRAINT_ERROR => + IF FL1 /= 50.0 THEN + FAILED ("VALUE ALTERED BEFORE FLTG PT RANGE EXCEPTION"); + END IF; + + END; + +------------------------- + + DECLARE + FL : FLOAT := 50.0; + FL2 : FLOAT RANGE 0.0 .. 100.0 := 50.0; + + BEGIN + IF EQUAL(3,3) THEN + FL := 0.0; + END IF; + FL2 := FL; + + EXCEPTION + WHEN CONSTRAINT_ERROR => + FAILED ("EXCEPTION RAISED ON LEGAL FLOATING PT ASSNMT"); + + END; + +---------------------- + + RESULT; +END C52005E; diff --git a/gcc/testsuite/ada/acats/tests/c5/c52005f.ada b/gcc/testsuite/ada/acats/tests/c5/c52005f.ada new file mode 100644 index 000000000..19d58d0e4 --- /dev/null +++ b/gcc/testsuite/ada/acats/tests/c5/c52005f.ada @@ -0,0 +1,86 @@ +-- C52005F.ADA + +-- Grant of Unlimited Rights +-- +-- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687, +-- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained +-- unlimited rights in the software and documentation contained herein. +-- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making +-- this public release, the Government intends to confer upon all +-- recipients unlimited rights equal to those held by the Government. +-- These rights include rights to use, duplicate, release or disclose the +-- released technical data and computer software in whole or in part, in +-- any manner and for any purpose whatsoever, and to have or permit others +-- to do so. +-- +-- DISCLAIMER +-- +-- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR +-- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED +-- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF 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 CONSTRAINT_ERROR EXCEPTION IS RAISED +-- WHEN A DYNAMIC EXPRESSION VALUE IS OUTSIDE THE STATIC RANGE +-- OF FIXED POINT ASSIGNMENTS. + +-- JRK 7/21/80 +-- SPS 3/21/83 + +WITH REPORT; +PROCEDURE C52005F IS + + USE REPORT; + +BEGIN + TEST ("C52005F", "CHECK THAT CONSTRAINT_ERROR EXCEPTION IS RAISED" + & " ON DYNAMIC OUT OF RANGE FIXED POINT ASSIGNMENTS"); + +----------------------- + + DECLARE + TYPE REAL IS DELTA 0.01 RANGE 0.00 .. 9.99; + FX : REAL := 4.50; + FX1 : REAL RANGE 0.00 .. 7.00 := 4.50; + + BEGIN + IF EQUAL(3,3) THEN + FX := 7.01; + END IF; + FX1 := FX; + + FAILED ("EXCEPTION NOT RAISED FOR OUT OF RANGE FIXED ASSNMT"); + + EXCEPTION + WHEN CONSTRAINT_ERROR => + IF FX1 /= 4.50 THEN + FAILED ("VALUE ALTERED BEFORE FIXED PT RANGE EXCEPTION"); + END IF; + + END; + +------------------------- + + DECLARE + TYPE REAL IS DELTA 0.01 RANGE 0.00 .. 9.99; + FX : REAL := 4.50; + FX2 : REAL RANGE 0.00 .. 7.00 := 4.50; + + BEGIN + IF EQUAL(3,3) THEN + FX := 7.00; + END IF; + FX2 := FX; + + EXCEPTION + WHEN CONSTRAINT_ERROR => + FAILED ("EXCEPTION RAISED ON LEGAL FIXED PT ASSNMT"); + + END; + +------------------------- + + RESULT; +END C52005F; diff --git a/gcc/testsuite/ada/acats/tests/c5/c52008a.ada b/gcc/testsuite/ada/acats/tests/c5/c52008a.ada new file mode 100644 index 000000000..ac0e8b05c --- /dev/null +++ b/gcc/testsuite/ada/acats/tests/c5/c52008a.ada @@ -0,0 +1,73 @@ +-- C52008A.ADA + +-- Grant of Unlimited Rights +-- +-- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687, +-- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained +-- unlimited rights in the software and documentation contained herein. +-- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making +-- this public release, the Government intends to confer upon all +-- recipients unlimited rights equal to those held by the Government. +-- These rights include rights to use, duplicate, release or disclose the +-- released technical data and computer software in whole or in part, in +-- any manner and for any purpose whatsoever, and to have or permit others +-- to do so. +-- +-- DISCLAIMER +-- +-- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR +-- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED +-- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF 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 RECORD VARIABLE CONSTRAINED BY A SPECIFIED DISCRIMINANT +-- VALUE CANNOT HAVE ITS DISCRIMINANT VALUE ALTERED BY ASSIGNMENT. +-- ASSIGNING AN ENTIRE RECORD VALUE WITH A DIFFERENT DISCRIMINANT VALUE +-- SHOULD RAISE CONSTRAINT_ERROR AND LEAVE THE TARGET VARIABLE +-- UNALTERED. THIS TEST USES STATIC DISCRIMINANT VALUES. + +-- ASL 6/25/81 +-- SPS 3/21/83 + +WITH REPORT; +PROCEDURE C52008A IS + + USE REPORT; + + TYPE REC(DISC : INTEGER) IS + RECORD + COMP : INTEGER; + END RECORD; + + R : REC(5) := (5,0); + +BEGIN + + TEST ("C52008A", "CANNOT ASSIGN RECORD VARIABLE WITH SPECIFIED " & + "DISCRIMINANT VALUE A VALUE WITH A DIFFERENT " & + "STATIC DISCRIMINANT VALUE"); + + BEGIN + R := (DISC => 5, COMP => 3); + IF R /= (5,3) THEN + FAILED ("LEGAL ASSIGNMENT FAILED"); + END IF; + R := (DISC => 4, COMP => 2); + FAILED ("RECORD ASSIGNED VALUE WITH DIFFERENT DISCRIMINANT " & + "VALUE"); + EXCEPTION + WHEN CONSTRAINT_ERROR => + IF R /= (5,3) THEN + FAILED ("TARGET RECORD VALUE ALTERED BY " & + "ASSIGNMENT TO VALUE WITH DIFFERENT " & + "DISCRIMINANT VALUE EVEN AFTER " & + "CONSTRAINT_ERROR RAISED"); + END IF; + WHEN OTHERS => FAILED ("WRONG EXCEPTION"); + END; + + RESULT; + +END C52008A; diff --git a/gcc/testsuite/ada/acats/tests/c5/c52008b.ada b/gcc/testsuite/ada/acats/tests/c5/c52008b.ada new file mode 100644 index 000000000..3d0fa8df1 --- /dev/null +++ b/gcc/testsuite/ada/acats/tests/c5/c52008b.ada @@ -0,0 +1,110 @@ +-- C52008B.ADA + +-- Grant of Unlimited Rights +-- +-- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687, +-- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained +-- unlimited rights in the software and documentation contained herein. +-- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making +-- this public release, the Government intends to confer upon all +-- recipients unlimited rights equal to those held by the Government. +-- These rights include rights to use, duplicate, release or disclose the +-- released technical data and computer software in whole or in part, in +-- any manner and for any purpose whatsoever, and to have or permit others +-- to do so. +-- +-- DISCLAIMER +-- +-- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR +-- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED +-- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF 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 RECORD VARIABLE DECLARED WITH A SPECIFIED +-- DISCRIMINANT CONSTRAINT CANNOT HAVE A DISCRIMINANT VALUE ALTERED +-- BY ASSIGNMENT. ASSIGNING AN ENTIRE RECORD VALUE WITH A +-- DIFFERENT DISCRIMINANT VALUE SHOULD RAISE CONSTRAINT_ERROR AND +-- LEAVE THE TARGET VARIABLE UNALTERED. THIS TEST USES NON-STATIC +-- DISCRIMINANT VALUES. + +-- HISTORY: +-- ASL 6/25/81 CREATED ORIGINAL TEST +-- JRK 11/18/82 +-- RJW 8/17/89 ADDED SUBTYPE 'SUBINT'. + +WITH REPORT; +PROCEDURE C52008B IS + + USE REPORT; + + TYPE REC1(D1,D2 : INTEGER) IS + RECORD + COMP1 : STRING(D1..D2); + END RECORD; + + TYPE AR_REC1 IS ARRAY (NATURAL RANGE <>) OF REC1(IDENT_INT(3), + IDENT_INT(5)); + + SUBTYPE SUBINT IS INTEGER RANGE -128 .. 127; + + TYPE REC2(D1,D2,D3,D4 : SUBINT := 0) IS + RECORD + COMP1 : STRING(1..D1); + COMP2 : STRING(D2..D3); + COMP5 : AR_REC1(1..D4); + COMP6 : REC1(D3,D4); + END RECORD; + + STR : STRING(IDENT_INT(3)..IDENT_INT(5)) := "ZZZ"; + + R1A : REC1(IDENT_INT(3),IDENT_INT(5)) := (3,5,STR); + R1C : REC1(5,6) := (5,6,COMP1 => (5..6 => 'K')); + + Q,R : REC2(IDENT_INT(2),IDENT_INT(3),IDENT_INT(5),IDENT_INT(6)); + TEMP : REC2(2,3,5,6); + + W : REC2(1,4,6,8); + OK : BOOLEAN := FALSE; + + +BEGIN + + TEST ("C52008B", "CANNOT ASSIGN RECORD VARIABLE WITH SPECIFIED " & + "DISCRIMINANT VALUE A VALUE WITH A DIFFERENT " & + "(DYNAMIC) DISCRIMINANT VALUE"); + + BEGIN + R1A := (IDENT_INT(3),5,"XYZ"); + + R := (IDENT_INT(2),IDENT_INT(3),IDENT_INT(5),IDENT_INT(6), + "AB", + STR, + (1..6 => R1A), + R1C); + + TEMP := R; + Q := TEMP; + R.COMP1 := "YY"; + OK := TRUE; + W := R; + FAILED ("ASSIGNMENT MADE USING INCORRECT DISCRIMINANT " & + "VALUES"); + EXCEPTION + WHEN CONSTRAINT_ERROR => + IF NOT OK + OR Q /= TEMP + OR R = TEMP + OR R = Q + OR W.D4 /= 8 THEN + FAILED ("LEGITIMATE ASSIGNMENT FAILED"); + END IF; + WHEN OTHERS => + FAILED ("WRONG EXCEPTION"); + END; + + RESULT; + +END C52008B; diff --git a/gcc/testsuite/ada/acats/tests/c5/c52009a.ada b/gcc/testsuite/ada/acats/tests/c5/c52009a.ada new file mode 100644 index 000000000..8a46f988c --- /dev/null +++ b/gcc/testsuite/ada/acats/tests/c5/c52009a.ada @@ -0,0 +1,77 @@ +-- C52009A.ADA + +-- Grant of Unlimited Rights +-- +-- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687, +-- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained +-- unlimited rights in the software and documentation contained herein. +-- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making +-- this public release, the Government intends to confer upon all +-- recipients unlimited rights equal to those held by the Government. +-- These rights include rights to use, duplicate, release or disclose the +-- released technical data and computer software in whole or in part, in +-- any manner and for any purpose whatsoever, and to have or permit others +-- to do so. +-- +-- DISCLAIMER +-- +-- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR +-- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED +-- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF 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 RECORD VARIABLE DESIGNATED BY AN ACCESS VALUE CANNOT +-- HAVE ITS DISCRIMINANT ALTERED, EVEN BY A COMPLETE RECORD +-- ASSIGNMENT, AND EVEN THOUGH THE THE TARGET ACCESS VARIABLE IS NOT +-- CONSTRAINED TO A SPECIFIC DISCRIMINANT VALUE. ATTEMPTING TO +-- CHANGE THE TARGET'S DISCRIMINANT RAISES CONSTRAINT_ERROR AND LEAVES +-- THE TARGET RECORD UNALTERED. THIS TEST USES STATIC DISCRIMINANT +-- VALUES. + +-- ASL 6/25/81 +-- SPS 10/26/82 + +WITH REPORT; +PROCEDURE C52009A IS + + USE REPORT; + + TYPE REC (DISC : INTEGER) IS + RECORD + COMP : INTEGER; + END RECORD; + + TYPE REC_NAME IS ACCESS REC; + + HR : REC_NAME := NEW REC'(5,0); + +BEGIN + + TEST ("C52009A", "CANNOT CHANGE, THROUGH ASSIGNMENT, THE " & + "(STATIC) DISCRIMINANT VALUE OF A RECORD DESIGNATED " & + "BY AN ACCESS VALUE"); + + BEGIN + HR.ALL := (DISC => 5, COMP => 3); + IF HR.ALL /= (5,3) THEN + FAILED ("LEGAL ASSIGNMENT FAILED"); + END IF; + HR.ALL := (DISC => 4, COMP => 2); + FAILED ("RECORD ASSIGNED VALUE WITH DIFFERENT DISCRIMINANT " & + "VALUE"); + EXCEPTION + WHEN CONSTRAINT_ERROR => + IF HR.ALL /= (5,3) THEN + FAILED ("TARGET RECORD VALUE ALTERED BY " & + "ASSIGNMENT WITH A DIFFERENT " & + "DISCRIMINANT VALUE EVEN AFTER " & + "CONSTRAINT_ERROR RAISED"); + END IF; + WHEN OTHERS => FAILED ("WRONG EXCEPTION"); + END; + + RESULT; + +END C52009A; diff --git a/gcc/testsuite/ada/acats/tests/c5/c52009b.ada b/gcc/testsuite/ada/acats/tests/c5/c52009b.ada new file mode 100644 index 000000000..98577fd53 --- /dev/null +++ b/gcc/testsuite/ada/acats/tests/c5/c52009b.ada @@ -0,0 +1,81 @@ +-- C52009B.ADA + +-- Grant of Unlimited Rights +-- +-- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687, +-- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained +-- unlimited rights in the software and documentation contained herein. +-- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making +-- this public release, the Government intends to confer upon all +-- recipients unlimited rights equal to those held by the Government. +-- These rights include rights to use, duplicate, release or disclose the +-- released technical data and computer software in whole or in part, in +-- any manner and for any purpose whatsoever, and to have or permit others +-- to do so. +-- +-- DISCLAIMER +-- +-- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR +-- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED +-- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF 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 RECORD VARIABLE DESIGNATED BY AN ACCESS VALUE CANNOT +-- HAVE ITS DISCRIMINANT ALTERED, EVEN BY A COMPLETE RECORD +-- ASSIGNMENT, AND EVEN THOUGH THE THE TARGET ACCESS VARIABLE IS NOT +-- CONSTRAINED TO A SPECIFIC DISCRIMINANT VALUE. ATTEMPTING TO +-- CHANGE THE TARGET'S DISCRIMINANT RAISES CONSTRAINT_ERROR AND LEAVES +-- THE TARGET RECORD UNALTERED. THIS TEST USES NON-STATIC DISCRIMINANT +-- VALUES AND A TYPE WITH DEFAULT DISCRIMINANTS. + +-- ASL 7/6/81 +-- SPS 10/26/82 +-- JBG 1/10/84 + +WITH REPORT; +PROCEDURE C52009B IS + + USE REPORT; + + TYPE REC(DISC : INTEGER := 5) IS + RECORD + COMP : INTEGER := 0; + END RECORD; + + TYPE REC_NAME IS ACCESS REC; + + HR : REC_NAME := NEW REC; + +BEGIN + + TEST ("C52009B", "CANNOT CHANGE, THROUGH ASSIGNMENT, THE " & + "(DYNAMIC) DISCRIMINANT VALUE OF A RECORD DESIGNATED " & + "BY AN ACCESS VALUE"); + + BEGIN + HR.ALL := (DISC => IDENT_INT(5), COMP => 3); + IF HR.ALL /= (IDENT_INT(5),3) THEN + FAILED ("LEGAL ASSIGNMENT FAILED"); + END IF; + EXCEPTION + WHEN CONSTRAINT_ERROR => + FAILED ("CONSTRAINT_ERROR RAISED WHEN DISCRIMINANT " & + "VALUE NOT CHANGED"); + END; + + BEGIN + HR.ALL := (DISC => IDENT_INT(4), COMP => 2); + FAILED ("RECORD ASSIGNED VALUE WITH DIFFERENT DISCRIMINANT " & + "VALUE"); + EXCEPTION + WHEN CONSTRAINT_ERROR => + COMMENT ("DETECTED ATTEMPT TO CHANGE DISCRIMINANT " & + "VALUE"); + WHEN OTHERS => FAILED ("WRONG EXCEPTION"); + END; + + RESULT; + +END C52009B; diff --git a/gcc/testsuite/ada/acats/tests/c5/c52010a.ada b/gcc/testsuite/ada/acats/tests/c5/c52010a.ada new file mode 100644 index 000000000..ddb58f7f6 --- /dev/null +++ b/gcc/testsuite/ada/acats/tests/c5/c52010a.ada @@ -0,0 +1,186 @@ +-- C52010A.ADA + +-- Grant of Unlimited Rights +-- +-- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687, +-- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained +-- unlimited rights in the software and documentation contained herein. +-- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making +-- this public release, the Government intends to confer upon all +-- recipients unlimited rights equal to those held by the Government. +-- These rights include rights to use, duplicate, release or disclose the +-- released technical data and computer software in whole or in part, in +-- any manner and for any purpose whatsoever, and to have or permit others +-- to do so. +-- +-- DISCLAIMER +-- +-- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR +-- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED +-- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF 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 RECORD ASSIGNMENTS USE "COPY" SEMANTICS. (PART I). + + +-- FACTORS AFFECTING THE SITUATION TO BE TESTED: +-- +-- COMPONENT TYPE * INTEGER +-- * BOOLEAN (OMITTED) +-- * CHARACTER (OMITTED) +-- * USER-DEFINED ENUMERATION +-- +-- DERIVED VS. NON-DERIVED +-- +-- TYPE VS. SUBTYPE +-- +-- ORDER OF COMPONENT ASSIGNMENTS * LEFT-TO-RIGHT +-- * RIGHT-TO-LEFT +-- * INSIDE-OUT +-- * OUTSIDE IN + + +-- RM 02/23/80 +-- SPS 3/21/83 + +WITH REPORT; +PROCEDURE C52010A IS + + USE REPORT; + + TYPE ENUM IS ( AA , BB , CC , DD , EE , FF , GG , HH , + II , JJ , KK , LL , MM , NN , PP , QQ , + TT , UU , VV , WW , XX , YY ); + +BEGIN + + TEST ( "C52010A" , "CHECK THAT RECORD ASSIGNMENTS USE ""COPY""" & + " SEMANTICS" ); + + + DECLARE + TYPE REC IS + RECORD + X , Y : INTEGER ; + END RECORD; + R : REC ; + BEGIN + + R := ( 5 , 8 ) ; + R := ( X => 1 , Y => R.X ) ; + IF R /= ( 1 , 5 ) THEN + FAILED ( "WRONG VALUE (1)" ); + END IF; + + R := ( 5 , 8 ) ; + R := ( Y => 1 , X => R.Y ) ; + IF R /= ( 8 , 1 ) THEN + FAILED ( "WRONG VALUE (2)" ); + END IF; + + R := ( 5 , 8 ) ; + R := ( R.Y+1 , R.X+1 ) ; + IF R /= ( 9 , 6 ) THEN + FAILED ( "WRONG VALUE (3)" ); + END IF; + + END; + + DECLARE + TYPE REC3 IS + RECORD + DEEP0 : INTEGER ; + DEEP : INTEGER ; + END RECORD; + TYPE REC2 IS + RECORD + YX : REC3 ; + MODERATE : INTEGER ; + END RECORD; + TYPE REC IS + RECORD + SHALLOW : INTEGER ; + YZ : REC2 ; + END RECORD; + R : REC ; + BEGIN + R := ( 0 , ((5, 1 ), 2 )); + R := ( R.YZ.MODERATE+8, ((7, R.SHALLOW+1),R.YZ.YX.DEEP+99)); + IF R/= ( 10, ((7, 1), 100)) + THEN + FAILED ( "WRONG VALUE (4)" ); + END IF; + END; + + + DECLARE + TYPE SUB_ENUM IS NEW ENUM RANGE AA..DD ; + TYPE REC IS + RECORD + X , Y : SUB_ENUM ; + END RECORD; + R : REC ; + BEGIN + R := ( AA , CC ) ; + R := ( X => BB , Y => R.X ) ; + IF R /= ( BB , AA ) THEN + FAILED ( "WRONG VALUE (5)" ); + END IF; + + R := ( AA , CC ) ; + R := ( Y => BB , X => R.Y ) ; + IF R /= ( CC , BB ) THEN + FAILED ( "WRONG VALUE (6)" ); + END IF; + + R := ( AA , CC ) ; + R := ( SUB_ENUM'SUCC( R.Y ) , SUB_ENUM'SUCC( R.X ) ) ; + IF R /= ( DD , BB ) THEN + FAILED ( "WRONG VALUE (7)" ); + END IF; + + END; + + + DECLARE + TYPE REC3 IS + RECORD + DEEP0 : ENUM ; + DEEP : ENUM ; + END RECORD; + TYPE REC2 IS + RECORD + YX : REC3 ; + MODERATE : ENUM ; + END RECORD; + TYPE REC IS + RECORD + SHALLOW : ENUM ; + YZ : REC2 ; + END RECORD; + R : REC ; + BEGIN + + R := ( TT , + (( YY , II ) , + AA ) ) ; + + R := ( ENUM'SUCC(ENUM'SUCC( R.YZ.MODERATE )) , + (( AA , ENUM'SUCC( R.SHALLOW ) ) , + ( ENUM'SUCC(ENUM'SUCC(ENUM'SUCC(ENUM'SUCC( + R.YZ.YX.DEEP )))) ) ) ) ; + + IF R/= ( CC , + (( AA , UU ) , + MM ) ) + THEN + FAILED ( "WRONG VALUE (8)" ); + END IF; + + END; + + RESULT ; + +END C52010A ; diff --git a/gcc/testsuite/ada/acats/tests/c5/c52011a.ada b/gcc/testsuite/ada/acats/tests/c5/c52011a.ada new file mode 100644 index 000000000..1f46c4da5 --- /dev/null +++ b/gcc/testsuite/ada/acats/tests/c5/c52011a.ada @@ -0,0 +1,170 @@ +-- C52011A.ADA + +-- Grant of Unlimited Rights +-- +-- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687, +-- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained +-- unlimited rights in the software and documentation contained herein. +-- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making +-- this public release, the Government intends to confer upon all +-- recipients unlimited rights equal to those held by the Government. +-- These rights include rights to use, duplicate, release or disclose the +-- released technical data and computer software in whole or in part, in +-- any manner and for any purpose whatsoever, and to have or permit others +-- to do so. +-- +-- DISCLAIMER +-- +-- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR +-- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED +-- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF 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 INDEX CONSTRAINTS FOR ASSIGNMENT OF ACCESS SUBTYPES. +-- SPECIFICALLY, CHECK THAT: + +-- A) ANY ACCESS TYPE VARIABLE AND CONSTRAINED SUBTYPE VARIABLES OF THAT +-- TYPE MAY BE ASSIGNED TO ONE ANOTHER IF THE VALUE BEING ASSIGNED +-- IS NULL. + +-- B) VARIABLES OF THE SAME CONSTRAINED ACCESS SUBTYPE MAY BE ASSIGNED +-- TO ONE ANOTHER OR TO VARIABLES OF THE BASE ACCESS TYPE. + +-- C) CONSTRAINT_ERROR IS RAISED UPON ASSIGNMENT OF NON-NULL OBJECTS +-- BETWEEN DIFFERENTLY CONSTRAINED ACCESS SUBTYPES. + +-- D) CONSTRAINT_ERROR IS RAISED UPON ASSIGNMENT OF A NON-NULL OBJECT +-- OF A BASE ACCESS TYPE VARIABLE TO A VARIABLE OF ONE OF ITS +-- CONSTRAINED SUBTYPES IF THE CONSTRAINTS ON THE OBJECT DIFFER +-- FROM THOSE ON THE SUBTYPE. + +-- E) NULL CAN BE ASSIGNED TO BASE ACCESS TYPES AND ANY CONSTRAINED +-- SUBTYPES OF THIS TYPE. + +-- ASL 6/29/81 +-- RM 6/17/82 +-- SPS 10/26/82 +-- RLB 6/29/01 - FIXED TO ALLOW AGGRESIVE OPTIMIZATION. + +WITH REPORT; +PROCEDURE C52011A IS + + USE REPORT; + + TYPE ARR IS ARRAY(INTEGER RANGE <>) OF INTEGER; + TYPE ARR_NAME IS ACCESS ARR; + SUBTYPE S1 IS ARR_NAME(IDENT_INT(1)..IDENT_INT(10)); + SUBTYPE S2 IS ARR_NAME(IDENT_INT(3)..IDENT_INT(6)); + + W : ARR_NAME := NULL; -- E. + X1,X2 : S1 := NULL; -- E. + Y1,Y2 : S2 := NULL; -- E. + + W_NONNULL : ARR_NAME := NEW ARR'(3..5=>7) ; + X1_NONNULL : S1 := NEW ARR'(IDENT_INT(1)..IDENT_INT(10)=>7); + Y1_NONNULL : S2 := NEW ARR'(IDENT_INT(3)..IDENT_INT( 6)=>7); + + TOO_EARLY : BOOLEAN := TRUE; + +BEGIN + + TEST ("C52011A", "INDEX CONSTRAINTS ON ACCESS SUBTYPE OBJECTS " & + "MUST BE SATISFIED FOR ASSIGNMENT"); + + BEGIN + + IF EQUAL(3,3) THEN + W_NONNULL := X1; -- A. + END IF; + IF W_NONNULL /= X1 THEN + FAILED ("ASSIGNMENT FAILED - 1"); + END IF; + + IF EQUAL(3,3) THEN + X1_NONNULL := X2; -- A. + END IF; + IF X1_NONNULL /= X2 THEN + FAILED ("ASSIGNMENT FAILED - 2"); + END IF; + + IF EQUAL(3,3) THEN + X1_NONNULL := Y1; -- A. + END IF; + IF X1 /= Y1 THEN + FAILED ("ASSIGNMENT FAILED - 3"); + END IF; + + X1 := NEW ARR'(1..IDENT_INT(10) => 5); + IF EQUAL(3,3) THEN + X2 := X1; -- B. + END IF; + IF X2 /= X1 THEN + FAILED ("ASSIGNMENT FAILED - 4"); + END IF; + + IF EQUAL(3,3) THEN + W := X1; -- B. + END IF; + IF W /= X1 THEN + FAILED ("ASSIGNMENT FAILED - 5"); + END IF; + + BEGIN + Y1 := X1; -- C. + IF Y1'FIRST /= REPORT.IDENT_INT(3) THEN + FAILED ("NON-NULL ASSIGNMENT MADE BETWEEN TWO " & + "VARIABLES OF DIFFERENT CONSTRAINED ACCESS SUBTYPES " & + "AND CONSTRAINT IS CHANGED"); + ELSE + FAILED ("NON-NULL ASSIGNMENT MADE BETWEEN TWO " & + "VARIABLES OF DIFFERENT CONSTRAINED ACCESS SUBTYPES " & + "AND CONSTRAINT IS NOT CHANGED"); + END IF; + EXCEPTION + + WHEN CONSTRAINT_ERROR => NULL; + + WHEN OTHERS => + FAILED ("WRONG EXCEPTION - 1"); + + END; + + W := NEW ARR'(IDENT_INT(3)..IDENT_INT(6) => 3); + + BEGIN + X1 := W; -- D. + IF X1'FIRST /= REPORT.IDENT_INT(1) THEN + FAILED ("NON-NULL ASSIGNMENT MADE FROM UNCONSTRAINED " & + "ACCESS TYPE DESIGNATING CONSTRAINED OBJECT TO "& + "ACCESS SUBTYPE WITH DIFFERENT CONSTRAINT " & + "AND CONSTRAINT IS CHANGED"); + ELSE + FAILED ("NON-NULL ASSIGNMENT MADE FROM UNCONSTRAINED " & + "ACCESS TYPE DESIGNATING CONSTRAINED OBJECT TO "& + "ACCESS SUBTYPE WITH DIFFERENT CONSTRAINT " & + "AND CONSTRAINT IS NOT CHANGED"); + END IF; + EXCEPTION + + WHEN CONSTRAINT_ERROR => + NULL ; + + WHEN OTHERS => + FAILED ("WRONG EXCEPTION - 2"); + + END; + + EXCEPTION + + WHEN OTHERS => + FAILED ("EXCEPTION RAISED"); + + END; + + + RESULT; + + +END C52011A; diff --git a/gcc/testsuite/ada/acats/tests/c5/c52011b.ada b/gcc/testsuite/ada/acats/tests/c5/c52011b.ada new file mode 100644 index 000000000..460f51835 --- /dev/null +++ b/gcc/testsuite/ada/acats/tests/c5/c52011b.ada @@ -0,0 +1,180 @@ +-- C52011B.ADA + +-- Grant of Unlimited Rights +-- +-- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687, +-- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained +-- unlimited rights in the software and documentation contained herein. +-- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making +-- this public release, the Government intends to confer upon all +-- recipients unlimited rights equal to those held by the Government. +-- These rights include rights to use, duplicate, release or disclose the +-- released technical data and computer software in whole or in part, in +-- any manner and for any purpose whatsoever, and to have or permit others +-- to do so. +-- +-- DISCLAIMER +-- +-- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR +-- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED +-- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF 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 DISCRIMINANT CONSTRAINTS FOR ASSIGNMENT OF ACCESS SUBTYPES. +-- SPECIFICALLY, CHECK THAT: + +-- A) ANY ACCESS TYPE VARIABLE AND CONSTRAINED SUBTYPE VARIABLES OF THAT +-- TYPE MAY BE ASSIGNED TO ONE ANOTHER IF THE VALUE BEING ASSIGNED +-- IS NULL. + +-- B) VARIABLES OF THE SAME CONSTRAINED ACCESS SUBTYPE MAY BE ASSIGNED +-- TO ONE ANOTHER OR TO VARIABLES OF THE BASE ACCESS TYPE. + +-- C) CONSTRAINT_ERROR IS RAISED UPON ASSIGNMENT OF NON-NULL OBJECTS +-- BETWEEN DIFFERENTLY CONSTRAINED ACCESS SUBTYPES. + +-- D) CONSTRAINT_ERROR IS RAISED UPON ASSIGNMENT OF A NON-NULL OBJECT +-- OF A BASE ACCESS TYPE VARIABLE TO A VARIABLE OF ONE OF ITS +-- CONSTRAINED SUBTYPES IF THE CONSTRAINTS ON THE OBJECT DIFFER +-- FROM THOSE ON THE SUBTYPE. + +-- E) NULL CAN BE ASSIGNED TO BASE ACCESS TYPES AND ANY CONSTRAINED +-- SUBTYPES OF THIS TYPE. + +-- ASL 7/06/81 +-- RM 6/17/82 +-- RLB 6/29/01 - FIXED TO ALLOW AGGRESIVE OPTIMIZATION. + +WITH REPORT; +PROCEDURE C52011B IS + + USE REPORT; + + TYPE REC(DISC : INTEGER := -1 ) IS + RECORD + NULL; + END RECORD; + + TYPE REC_NAME IS ACCESS REC; + SUBTYPE S1 IS REC_NAME(IDENT_INT(5)); + SUBTYPE S2 IS REC_NAME(IDENT_INT(3)); + + W : REC_NAME := NULL; -- E. + X1,X2 : S1 := NULL; -- E. + Y1,Y2 : S2 := NULL; -- E. + + W_NONNULL : REC_NAME := NEW REC(7) ; + X1_NONNULL : S1 := NEW REC(IDENT_INT(5)); + Y1_NONNULL : S2 := NEW REC(IDENT_INT(3)); + + TOO_EARLY : BOOLEAN := TRUE; + +BEGIN + + TEST ("C52011B", "DISCRIMINANT CONSTRAINTS ON ACCESS SUBTYPE " & + "OBJECTS MUST BE SATISFIED FOR ASSIGNMENT"); + + BEGIN + + IF EQUAL(3,3) THEN + W_NONNULL := X1; -- A. + END IF; + IF W_NONNULL /= X1 THEN + FAILED ("ASSIGNMENT FAILED - 1"); + END IF; + + IF EQUAL(3,3) THEN + W := Y1; -- A. + END IF; + IF W /= Y1 THEN + FAILED ("ASSIGNMENT FAILED - 2"); + END IF; + + IF EQUAL(3,3) THEN + X1_NONNULL := Y1; -- A. + END IF; + IF X1_NONNULL /= Y1 THEN + FAILED ("ASSIGNMENT FAILED - 3"); + END IF; + + IF EQUAL(3,3) THEN + Y1_NONNULL := Y2; -- A. + END IF; + IF Y1_NONNULL /= Y2 THEN + FAILED ("ASSIGNMENT FAILED - 4"); + END IF; + + X1 := NEW REC(IDENT_INT(5)); + IF EQUAL(3,3) THEN + X2 := X1; -- B. + END IF; + IF X1 /= X2 THEN + FAILED ("ASSIGNMENT FAILED - 5"); + END IF; + + IF EQUAL(3,3) THEN + W := X1; -- B. + END IF; + IF W /= X1 THEN + FAILED ("ASSIGNMENT FAILED - 6"); + END IF; + + BEGIN + Y1 := X1; -- C. + IF Y1.DISC /= REPORT.IDENT_INT(3) THEN + FAILED ("NON-NULL ASSIGNMENT MADE BETWEEN TWO " & + "VARIABLES OF DIFFERENT CONSTRAINED ACCESS SUBTYPES " & + "AND CONSTRAINT IS CHANGED"); + ELSE + FAILED ("NON-NULL ASSIGNMENT MADE BETWEEN TWO " & + "VARIABLES OF DIFFERENT CONSTRAINED ACCESS SUBTYPES " & + "AND CONSTRAINT IS NOT CHANGED"); + END IF; + EXCEPTION + + WHEN CONSTRAINT_ERROR => NULL; + + WHEN OTHERS => + FAILED ("WRONG EXCEPTION - 1"); + + END; + + W := NEW REC(IDENT_INT(3)); + + BEGIN + X1 := W; -- D. + IF X1.DISC /= REPORT.IDENT_INT(5) THEN + FAILED ("NON-NULL ASSIGNMENT MADE FROM UNCONSTRAINED " & + "ACCESS TYPE DESIGNATING CONSTRAINED OBJECT TO "& + "ACCESS SUBTYPE WITH DIFFERENT CONSTRAINT " & + "AND CONSTRAINT IS CHANGED"); + ELSE + FAILED ("NON-NULL ASSIGNMENT MADE FROM UNCONSTRAINED " & + "ACCESS TYPE DESIGNATING CONSTRAINED OBJECT TO "& + "ACCESS SUBTYPE WITH DIFFERENT CONSTRAINT " & + "AND CONSTRAINT IS NOT CHANGED"); + END IF; + EXCEPTION + + WHEN CONSTRAINT_ERROR => + NULL ; + + WHEN OTHERS => + FAILED ("WRONG EXCEPTION - 2"); + + END; + + EXCEPTION + + WHEN OTHERS => + FAILED ("EXCEPTION RAISED"); + + END; + + + RESULT; + + +END C52011B; diff --git a/gcc/testsuite/ada/acats/tests/c5/c52101a.ada b/gcc/testsuite/ada/acats/tests/c5/c52101a.ada new file mode 100644 index 000000000..87a450040 --- /dev/null +++ b/gcc/testsuite/ada/acats/tests/c5/c52101a.ada @@ -0,0 +1,81 @@ +-- C52101A.ADA + +-- Grant of Unlimited Rights +-- +-- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687, +-- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained +-- unlimited rights in the software and documentation contained herein. +-- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making +-- this public release, the Government intends to confer upon all +-- recipients unlimited rights equal to those held by the Government. +-- These rights include rights to use, duplicate, release or disclose the +-- released technical data and computer software in whole or in part, in +-- any manner and for any purpose whatsoever, and to have or permit others +-- to do so. +-- +-- DISCLAIMER +-- +-- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR +-- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED +-- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF 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 ARRAY SUBTYPE CONVERSION IS APPLIED AFTER AN ARRAY VALUE +-- IS DETERMINED. + +-- BHS 6/22/84 + +WITH REPORT; +PROCEDURE C52101A IS + + USE REPORT; + + TYPE DAY IS (MON, TUE, WED, THU, FRI, SAT, SUN); + SUBTYPE WEEKDAY IS DAY RANGE MON..FRI; + + TYPE ARR IS ARRAY (WEEKDAY RANGE <>) OF INTEGER; + TYPE ARR_DAY IS ARRAY (DAY RANGE <>) OF INTEGER; + + NORM : ARR (MON..FRI); -- INDEX SUBTYPE WEEKDAY + NORM_DAY : ARR_DAY (MON..FRI); -- INDEX SUBTYPE DAY + +BEGIN + TEST ("C52101A", "CHECK THAT ARRAY SUBTYPE CONVERSION " & + "APPLIED AFTER ARRAY VAL. DETERMINED"); + + BEGIN -- ILLEGAL CASE + NORM := (WED..SUN => 0); -- ERROR: INDEX SUBTYPE + + FAILED ("EXCEPTION NOT RAISED FOR INDEX SUBTYPE ERROR"); + + EXCEPTION + WHEN CONSTRAINT_ERROR => + COMMENT ("IMPROPER AGGREGATE BOUNDS DETECTED"); + WHEN OTHERS => + FAILED ("UNEXPECTED EXCEPTION RAISED"); + + END; + + + BEGIN -- LEGAL CASE + NORM_DAY := (WED..FRI => 0, SAT..SUN => 1); + IF NORM_DAY /= ( 0, 0, IDENT_INT(0), IDENT_INT(1), + IDENT_INT(1)) THEN + FAILED ("INCORRECT ASSIGNMENT IN LEGAL CASE"); + END IF; + + EXCEPTION + WHEN CONSTRAINT_ERROR => + FAILED ("CONSTRAINT_ERROR RAISED ON LEGAL INDEX " & + "SUBTYPE CONVERSION"); + WHEN OTHERS => + FAILED ("UNEXPECTED EXCEPTION RAISED IN LEGAL CASE"); + + END; + + + RESULT; + +END C52101A; diff --git a/gcc/testsuite/ada/acats/tests/c5/c52102a.ada b/gcc/testsuite/ada/acats/tests/c5/c52102a.ada new file mode 100644 index 000000000..0d686edd5 --- /dev/null +++ b/gcc/testsuite/ada/acats/tests/c5/c52102a.ada @@ -0,0 +1,251 @@ +-- C52102A.ADA + +-- Grant of Unlimited Rights +-- +-- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687, +-- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained +-- unlimited rights in the software and documentation contained herein. +-- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making +-- this public release, the Government intends to confer upon all +-- recipients unlimited rights equal to those held by the Government. +-- These rights include rights to use, duplicate, release or disclose the +-- released technical data and computer software in whole or in part, in +-- any manner and for any purpose whatsoever, and to have or permit others +-- to do so. +-- +-- DISCLAIMER +-- +-- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR +-- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED +-- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF 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 ASSIGNMENT OF OVERLAPPING SOURCE AND TARGET VARIABLES +-- (INCLUDING ARRAYS AND SLICES IN VARIOUS COMBINATIONS) SATISFIES +-- THE SEMANTICS OF "COPY" ASSIGNMENT. (THIS TEST IS IN TWO PARTS, +-- COVERING RESPECTIVELY STATIC AND DYNAMIC BOUNDS.) + +-- PART 1: STATIC BOUNDS + + +-- RM 02/25/80 +-- SPS 2/18/83 +-- JBG 8/21/83 +-- JBG 5/8/84 +-- JBG 6/09/84 + +WITH REPORT; +PROCEDURE C52102A IS + + USE REPORT; + + +BEGIN + + + TEST( "C52102A" , "CHECK THAT THE ASSIGNMENT OF OVERLAPPING " & + "SOURCE AND TARGET VARIABLES (INCLUDING " & + "ARRAYS AND SLICES IN VARIOUS COMBINATIONS) " & + "SATISFIES THE SEMANTICS OF ""COPY"" " & + "ASSIGNMENT (PART 1: STATIC BOUNDS)" ); + + + ------------------------------------------------------------------- + -------------------- ARRAYS OF INTEGERS ------------------------- + + DECLARE + A : ARRAY( 1..4 ) OF INTEGER; + + BEGIN + A := ( 11 , 12 , 13 , 14 ); + A := ( 1 , A(1) , A(2) , A(1) ); + IF A /= ( 1 , 11 , 12 , 11 ) THEN + FAILED( "WRONG VALUES - I1" ); + END IF; + + A := ( 11 , 12 , 13 , 14 ); + A := ( A(4) , A(3) , A(4) , 1 ); + IF A /= ( 14 , 13 , 14 , 1 ) THEN + FAILED( "WRONG VALUES - I2" ); + END IF; + + END; + + + DECLARE + A : ARRAY( INTEGER RANGE -4..4 ) OF INTEGER; + + BEGIN + A := ( -4 , -3 , -2 , -1 , 100 , 1 , 2 , 3 , 4 ); + A(-4..0) := A(0..4); + IF A /= ( 100 , 1 , 2 , 3 , 4 , 1 , 2 , 3 , 4 ) + THEN + FAILED( "WRONG VALUES - I3" ); + END IF; + + A := ( -4 , -3 , -2 , -1 , 100 , 1 , 2 , 3 , 4 ); + A(0..4) := A(-4..0); + IF A /= ( -4 , -3 , -2 , -1 , -4 , -3 , -2 , -1 , 100 ) + THEN + FAILED( "WRONG VALUES - I4" ); + END IF; + + END; + + + DECLARE + TYPE INT_ARR IS ARRAY (INTEGER RANGE <>) OF INTEGER; + A : INT_ARR (1..10); + + BEGIN + A := ( 1 , 2 , 3 , 4 , 5 , 6 , 7 , 8 , 9 , 10 ); + A := 0 & A(1..2) & A(1..2) & A(1..5); + IF A /= ( 0 , 1 , 2 , 1 , 2 , 1 , 2 , 3 , 4 , 5 ) + THEN + FAILED( "WRONG VALUES - I5" ); + END IF; + + A := ( 1 , 2 , 3 , 4 , 5 , 6 , 7 , 8 , 9 , 10 ); + A := A(6..9) & A(8..9) & A(8..9) & 0 & 0; + IF A /= ( 6 , 7 , 8 , 9 , 8 , 9 , 8 , 9 , 0 , 0 ) + THEN + FAILED( "WRONG VALUES - I6" ); + END IF; + + END; + + + ------------------------------------------------------------------- + -------------------- ARRAYS OF BOOLEANS ------------------------- + + DECLARE + A : ARRAY( 1..4 ) OF BOOLEAN; + + BEGIN + A := ( FALSE , TRUE , TRUE , FALSE ); + A := ( TRUE , A(1) , A(2) , A(1) ); + IF A /= ( TRUE , FALSE , TRUE , FALSE ) + THEN + FAILED( "WRONG VALUES - B1" ); + END IF; + + A := ( FALSE , TRUE , TRUE , FALSE ); + A := ( A(4) , A(3) , A(4) , TRUE ); + IF A /= ( FALSE , TRUE , FALSE, TRUE ) + THEN + FAILED( "WRONG VALUES - B2" ); + END IF; + + END; + + + DECLARE + A : ARRAY( INTEGER RANGE -4..4 ) OF BOOLEAN; + + BEGIN + A := (FALSE,FALSE,FALSE,FALSE,FALSE,TRUE, TRUE, TRUE,TRUE); + A(-4..0) := A(0..4); + IF A /= (FALSE, TRUE, TRUE, TRUE, TRUE,TRUE, TRUE, TRUE,TRUE) + THEN + FAILED( "WRONG VALUES - B3" ); + END IF; + + A := (FALSE,FALSE,FALSE,FALSE, TRUE,TRUE, TRUE, TRUE,TRUE); + A(0..4) := A(-4..0); + IF A /= (FALSE,FALSE,FALSE,FALSE,FALSE,FALSE,FALSE,FALSE,TRUE) + THEN + FAILED( "WRONG VALUES - B4" ); + END IF; + + END; + + + DECLARE + TYPE B_ARR IS ARRAY (INTEGER RANGE <>) OF BOOLEAN; + A : B_ARR (1..10); + + BEGIN + A := (TRUE,FALSE,TRUE,FALSE,TRUE,FALSE,TRUE,FALSE,TRUE,FALSE); + A := FALSE & A(1..2) & A(1..2) & A(1..5); + IF A/=(FALSE,TRUE,FALSE,TRUE,FALSE,TRUE,FALSE,TRUE,FALSE,TRUE) + THEN + FAILED( "WRONG VALUES - B5" ); + END IF; + + A := (TRUE,FALSE,TRUE,FALSE,TRUE,FALSE,TRUE,FALSE,TRUE,FALSE); + A := A(6..9) & A(8..9) & A(8..9) & FALSE & TRUE; + IF A/=(FALSE,TRUE,FALSE,TRUE,FALSE,TRUE,FALSE,TRUE,FALSE,TRUE) + THEN + FAILED( "WRONG VALUES - B6" ); + END IF; + + END; + + + ------------------------------------------------------------------- + -------------------- CHARACTER STRINGS -------------------------- + + DECLARE + A : STRING( 1..4 ); + + BEGIN + A := "ARGH"; + A := ( 'Q' , A(1) , A(2) , A(1) ); + IF A /= "QARA" THEN + FAILED( "WRONG VALUES - C1" ); + END IF; + + A := "ARGH"; + A := ( A(4) , A(3) , A(4) , 'X' ); + IF A /= "HGHX" THEN + FAILED( "WRONG VALUES - C2" ); + END IF; + + END; + + + DECLARE + A : STRING( 96..104 ); + + BEGIN + A := "APHRODITE"; + A(96..100) := A(100..104); + IF A /= "ODITEDITE" THEN + FAILED( "WRONG VALUES - C3" ); + END IF; + + A := "APHRODITE"; + A(100..104) := A(96..100) ; + IF A /= "APHRAPHRO" THEN + FAILED( "WRONG VALUES - C4" ); + END IF; + + END; + + + DECLARE + TYPE CH_ARR IS ARRAY (INTEGER RANGE <>) OF CHARACTER; + A : CH_ARR (1..9); + + BEGIN + A := "CAMBRIDGE"; + A := 'S' & A(1..2) & A(1..2) & A(1..4); + IF A /= "SCACACAMB" THEN + FAILED( "WRONG VALUES - C5" ); + END IF; + + A := "CAMBRIDGE"; + A := A(8..8) & A(6..8) & A(6..8) & "EA"; + IF A /= "GIDGIDGEA" THEN + FAILED( "WRONG VALUES - C6" ); + END IF; + + END; + + + RESULT; + + +END C52102A; diff --git a/gcc/testsuite/ada/acats/tests/c5/c52102b.ada b/gcc/testsuite/ada/acats/tests/c5/c52102b.ada new file mode 100644 index 000000000..79b304947 --- /dev/null +++ b/gcc/testsuite/ada/acats/tests/c5/c52102b.ada @@ -0,0 +1,278 @@ +-- C52102B.ADA + +-- Grant of Unlimited Rights +-- +-- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687, +-- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained +-- unlimited rights in the software and documentation contained herein. +-- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making +-- this public release, the Government intends to confer upon all +-- recipients unlimited rights equal to those held by the Government. +-- These rights include rights to use, duplicate, release or disclose the +-- released technical data and computer software in whole or in part, in +-- any manner and for any purpose whatsoever, and to have or permit others +-- to do so. +-- +-- DISCLAIMER +-- +-- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR +-- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED +-- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF 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 ASSIGNMENT OF OVERLAPPING SOURCE AND TARGET VARIABLES +-- (INCLUDING ARRAYS AND SLICES IN VARIOUS COMBINATIONS) SATISFIES +-- THE SEMANTICS OF "COPY" ASSIGNMENT. (THIS TEST IS IN TWO PARTS, +-- COVERING RESPECTIVELY STATIC AND DYNAMIC BOUNDS.) + +-- PART 2: DYNAMIC BOUNDS + + +-- RM 02/27/80 +-- SPS 2/18/83 +-- JBG 3/15/84 +-- JBG 6/9/84 + +WITH REPORT; +PROCEDURE C52102B IS + + USE REPORT; + IDENT_INT_0 : INTEGER := IDENT_INT(0); + IDENT_INT_1 : INTEGER := IDENT_INT (1); + IDENT_INT_2 : INTEGER := IDENT_INT (2); + IDENT_INT_3 : INTEGER := IDENT_INT (3); + IDENT_INT_4 : INTEGER := IDENT_INT (4); + IDENT_INT_5 : INTEGER := IDENT_INT (5); + IDENT_INT_6 : INTEGER := IDENT_INT (6); + IDENT_INT_8 : INTEGER := IDENT_INT (8); + IDENT_INT_9 : INTEGER := IDENT_INT (9); + +BEGIN + + + TEST( "C52102B" , "CHECK THAT THE ASSIGNMENT OF OVERLAPPING " & + "SOURCE AND TARGET VARIABLES (INCLUDING " & + "ARRAYS AND SLICES IN VARIOUS COMBINATIONS) " & + "SATISFIES THE SEMANTICS OF ""COPY"" " & + "ASSIGNMENT (PART 2: DYNAMIC BOUNDS)" ); + + + ------------------------------------------------------------------- + -------------------- ARRAYS OF INTEGERS ------------------------- + + DECLARE + A : ARRAY( 1..IDENT_INT_4 ) OF INTEGER; + + BEGIN + A := ( 11 , 12 , 13 , 14 ); + A := ( 1 , A(IDENT_INT_1) , A(IDENT_INT_2) , + A(IDENT_INT_1) ); + IF A /= ( 1 , 11 , 12 , 11 ) THEN + FAILED( "WRONG VALUES - I1" ); + END IF; + + A := ( 11 , 12 , 13 , 14 ); + A := ( A(IDENT_INT_4) , A(IDENT_INT_3) , + A(IDENT_INT_4) , 1 ); + IF A /= ( 14 , 13 , 14 , 1 ) THEN + FAILED( "WRONG VALUES - I2" ); + END IF; + + END; + + + DECLARE + A : ARRAY( -4..IDENT_INT_4 ) OF INTEGER; + + BEGIN + A := ( -4 , -3 , -2 , -1 , 100 , 1 , 2 , 3 , 4 ); + A(-4..IDENT_INT_0) := A(IDENT_INT_0..4); + IF A /= ( 100 , 1 , 2 , 3 , 4 , 1 , 2 , 3 , 4 ) + THEN + FAILED( "WRONG VALUES - I3" ); + END IF; + + A := ( -4 , -3 , -2 , -1 , 100 , 1 , 2 , 3 , 4 ); + A(IDENT_INT_0..4) := A(-4..IDENT_INT_0); + IF A /= ( -4 , -3 , -2 , -1 , -4 , -3 , -2 , -1 , 100 ) + THEN + FAILED( "WRONG VALUES - I4" ); + END IF; + + END; + + + DECLARE + TYPE ARR IS ARRAY (INTEGER RANGE <>) OF INTEGER; + A : ARR (1..10); + + BEGIN + A := ( 1 , 2 , 3 , 4 , 5 , 6 , 7 , 8 , 9 , 10 ); + A := 0 & A(IDENT_INT_1..IDENT_INT_2) & + A(IDENT_INT_1..IDENT_INT_2) & + A(IDENT_INT_1..IDENT_INT_5); + IF A /= ( 0 , 1 , 2 , 1 , 2 , 1 , 2 , 3 , 4 , 5 ) + THEN + FAILED( "WRONG VALUES - I5" ); + END IF; + + A := ( 1 , 2 , 3 , 4 , 5 , 6 , 7 , 8 , 9 , 10 ); + A := A(IDENT_INT_6..IDENT_INT_9) & + A(IDENT_INT_8..IDENT_INT_9) & + A(IDENT_INT_8..IDENT_INT_9) & 0 & 0; + IF A /= ( 6 , 7 , 8 , 9 , 8 , 9 , 8 , 9 , 0 , 0 ) + THEN + FAILED( "WRONG VALUES - I6" ); + END IF; + + END; + + + ------------------------------------------------------------------- + -------------------- ARRAYS OF BOOLEANS ------------------------- + + DECLARE + A : ARRAY( 1..4 ) OF BOOLEAN; + + BEGIN + A := ( FALSE , TRUE , TRUE , FALSE ); + A := ( TRUE , A(IDENT_INT_1) , A(IDENT_INT_2) , + A(IDENT_INT_1) ); + IF A /= ( TRUE , FALSE , TRUE , FALSE ) + THEN + FAILED( "WRONG VALUES - B1" ); + END IF; + + A := ( FALSE , TRUE , TRUE , FALSE ); + A := ( A(IDENT_INT_4) , A(IDENT_INT_3) , + A(IDENT_INT_4) , TRUE ); + IF A /= ( FALSE , TRUE , FALSE, TRUE ) + THEN + FAILED( "WRONG VALUES - B2" ); + END IF; + + END; + + + DECLARE + A : ARRAY( -IDENT_INT_4..4 ) OF BOOLEAN; + + BEGIN + A := (FALSE,FALSE,FALSE,FALSE,FALSE,TRUE, TRUE, TRUE,TRUE); + A(-IDENT_INT_4..IDENT_INT_0) := A(IDENT_INT_0..4); + IF A /= (FALSE, TRUE, TRUE, TRUE, TRUE,TRUE, TRUE, TRUE,TRUE) + THEN + FAILED( "WRONG VALUES - B3" ); + END IF; + + A := (FALSE,FALSE,FALSE,FALSE, TRUE,TRUE, TRUE, TRUE,TRUE); + A(IDENT_INT_0..4) := A(-4..IDENT_INT_0); + IF A /= (FALSE,FALSE,FALSE,FALSE,FALSE,FALSE,FALSE,FALSE,TRUE) + THEN + FAILED( "WRONG VALUES - B4" ); + END IF; + + END; + + + DECLARE + TYPE B_ARR IS ARRAY (INTEGER RANGE <>) OF BOOLEAN; + A : B_ARR (1..10); + + BEGIN + A := (TRUE,FALSE,TRUE,FALSE,TRUE,FALSE,TRUE,FALSE,TRUE,FALSE); + A := FALSE & A(IDENT_INT_1..IDENT_INT_2) & + A(IDENT_INT_1..IDENT_INT_2) & + A(IDENT_INT_1..IDENT_INT_5); + IF A/=(FALSE,TRUE,FALSE,TRUE,FALSE,TRUE,FALSE,TRUE,FALSE,TRUE) + THEN + FAILED( "WRONG VALUES - B5" ); + END IF; + + A := (TRUE,FALSE,TRUE,FALSE,TRUE,FALSE,TRUE,FALSE,TRUE,FALSE); + A := A(IDENT_INT_6..IDENT_INT_9) & + A(IDENT_INT_8..IDENT_INT_9) & + A(IDENT_INT_8..IDENT_INT_9) & FALSE & TRUE; + IF A/=(FALSE,TRUE,FALSE,TRUE,FALSE,TRUE,FALSE,TRUE,FALSE,TRUE) + THEN + FAILED( "WRONG VALUES - B6" ); + END IF; + + END; + + + ------------------------------------------------------------------- + -------------------- CHARACTER STRINGS -------------------------- + + DECLARE + A : STRING( 1..4 ); + + BEGIN + A := "ARGH"; + A := ( 'Q' , A(IDENT_INT_1) , A(IDENT_INT_2) , + A(IDENT_INT_1) ); + IF A /= "QARA" THEN + FAILED( "WRONG VALUES - C1" ); + END IF; + + A := "ARGH"; + A := ( A(IDENT_INT_4) , A(IDENT_INT_3) , + A(IDENT_INT_4) , 'X' ); + IF A /= "HGHX" THEN + FAILED( "WRONG VALUES - C2" ); + END IF; + + END; + + + DECLARE + A : STRING( IDENT_INT(96)..104 ); + + BEGIN + A := "APHRODITE"; + A(IDENT_INT(96)..IDENT_INT(100)) := A(IDENT_INT(100).. + IDENT_INT(104)); + IF A /= "ODITEDITE" THEN + FAILED( "WRONG VALUES - C3" ); + END IF; + + A := "APHRODITE"; + A(IDENT_INT(100)..IDENT_INT(104)) := A(IDENT_INT(96).. + IDENT_INT(100)) ; + IF A /= "APHRAPHRO" THEN + FAILED( "WRONG VALUES - C4" ); + END IF; + + END; + + + DECLARE + TYPE CH_ARR IS ARRAY (INTEGER RANGE <>) OF CHARACTER; + A : CH_ARR (IDENT_INT_1..9); + + BEGIN + A := "CAMBRIDGE"; + A := 'S' & A(IDENT_INT_1..IDENT_INT_2) & + A(IDENT_INT_1..IDENT_INT_2) & + A(IDENT_INT_1..IDENT_INT_4); + IF A /= "SCACACAMB" THEN + FAILED( "WRONG VALUES - C5" ); + END IF; + + A := "CAMBRIDGE"; + A := A(IDENT_INT_8..IDENT_INT_8) & + A(IDENT_INT_6..IDENT_INT_8) & + A(IDENT_INT_6..IDENT_INT_8) & "EA"; + IF A /= "GIDGIDGEA" THEN + FAILED( "WRONG VALUES - C6" ); + END IF; + + END; + + + RESULT; + + +END C52102B; diff --git a/gcc/testsuite/ada/acats/tests/c5/c52102c.ada b/gcc/testsuite/ada/acats/tests/c5/c52102c.ada new file mode 100644 index 000000000..17fdf43f9 --- /dev/null +++ b/gcc/testsuite/ada/acats/tests/c5/c52102c.ada @@ -0,0 +1,280 @@ +-- C52102C.ADA + +-- Grant of Unlimited Rights +-- +-- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687, +-- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained +-- unlimited rights in the software and documentation contained herein. +-- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making +-- this public release, the Government intends to confer upon all +-- recipients unlimited rights equal to those held by the Government. +-- These rights include rights to use, duplicate, release or disclose the +-- released technical data and computer software in whole or in part, in +-- any manner and for any purpose whatsoever, and to have or permit others +-- to do so. +-- +-- DISCLAIMER +-- +-- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR +-- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED +-- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF 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 ASSIGNMENT OF OVERLAPPING SOURCE AND TARGET VARIABLES +-- (INCLUDING ARRAYS AND SLICES IN VARIOUS COMBINATIONS) SATISFIES +-- THE SEMANTICS OF "COPY" ASSIGNMENT WHEN INITIAL ASSIGNMENT VALUES +-- REQUIRE RUN-TIME EVALUATION. (THIS TEST IS IN TWO PARTS, +-- COVERING RESPECTIVELY STATIC AND DYNAMIC BOUNDS.) + +-- PART 1: STATIC BOUNDS + + +-- RM 02/25/80 +-- SPS 2/18/83 +-- JBG 8/21/83 +-- JBG 5/8/84 +-- JBG 6/09/84 +-- BHS 6/26/84 + +WITH REPORT; +PROCEDURE C52102C IS + + USE REPORT; + + FUNCTION ID_I (X : INTEGER) RETURN INTEGER RENAMES IDENT_INT; + FUNCTION ID_B (X : BOOLEAN) RETURN BOOLEAN RENAMES IDENT_BOOL; + +BEGIN + + + TEST( "C52102C" , "CHECK THAT THE ASSIGNMENT OF OVERLAPPING " & + "SOURCE AND TARGET VARIABLES (INCLUDING " & + "ARRAYS AND SLICES IN VARIOUS COMBINATIONS) " & + "SATISFIES THE SEMANTICS OF ""COPY"" " & + "ASSIGNMENT WHEN INITIAL ASSIGNMENT VALUES " & + "ARE DYNAMIC (PART 1: STATIC BOUNDS)" ); + + + ------------------------------------------------------------------- + -------------------- ARRAYS OF INTEGERS ------------------------- + + DECLARE + A : ARRAY( 1..4 ) OF INTEGER; + + BEGIN + A := ( ID_I(11), ID_I(12), ID_I(13), ID_I(14)); + A := ( 1 , A(1) , A(2) , A(1) ); + IF A /= ( 1 , 11 , 12 , 11 ) THEN + FAILED( "WRONG VALUES - I1" ); + END IF; + + A := ( ID_I(11), ID_I(12), ID_I(13), ID_I(14)); + A := ( A(4) , A(3) , A(4) , 1 ); + IF A /= ( 14 , 13 , 14 , 1 ) THEN + FAILED( "WRONG VALUES - I2" ); + END IF; + + END; + + + DECLARE + A : ARRAY( INTEGER RANGE -4..4 ) OF INTEGER; + + BEGIN + A := ( -ID_I(4), -ID_I(3), -ID_I(2), -ID_I(1), + ID_I(100), ID_I(1),ID_I(2), ID_I(3), ID_I(4) ); + A(-4..0) := A(0..4); + IF A /= ( 100 , 1 , 2 , 3 , 4 , 1 , 2 , 3 , 4 ) + THEN + FAILED( "WRONG VALUES - I3" ); + END IF; + + A := ( -ID_I(4), -ID_I(3), -ID_I(2), -ID_I(1), + ID_I(100), ID_I(1), ID_I(2), ID_I(3), ID_I(4) ); + A(0..4) := A(-4..0); + IF A /= ( -4 , -3 , -2 , -1 , -4 , -3 , -2 , -1 , 100 ) + THEN + FAILED( "WRONG VALUES - I4" ); + END IF; + + END; + + + DECLARE + TYPE INT_ARR IS ARRAY (INTEGER RANGE <>) OF INTEGER; + A : INT_ARR (1..10); + + BEGIN + A := ( ID_I(1), ID_I(2), ID_I(3), ID_I(4), ID_I(5), + ID_I(6), ID_I(7), ID_I(8), ID_I(9), ID_I(10) ); + A := 0 & A(1..2) & A(1..2) & A(1..5); + IF A /= ( 0 , 1 , 2 , 1 , 2 , 1 , 2 , 3 , 4 , 5 ) + THEN + FAILED( "WRONG VALUES - I5" ); + END IF; + + A := ( ID_I(1), ID_I(2), ID_I(3), ID_I(4), ID_I(5), + ID_I(6), ID_I(7), ID_I(8), ID_I(9), ID_I(10) ); + A := A(6..9) & A(8..9) & A(8..9) & 0 & 0; + IF A /= ( 6 , 7 , 8 , 9 , 8 , 9 , 8 , 9 , 0 , 0 ) + THEN + FAILED( "WRONG VALUES - I6" ); + END IF; + + END; + + + ------------------------------------------------------------------- + -------------------- ARRAYS OF BOOLEANS ------------------------- + + DECLARE + A : ARRAY( 1..4 ) OF BOOLEAN; + + BEGIN + A := (ID_B(FALSE), ID_B(TRUE), ID_B(TRUE), ID_B(FALSE)); + A := ( TRUE , A(1) , A(2) , A(1) ); + IF A /= ( TRUE ,FALSE , TRUE , FALSE ) + THEN + FAILED( "WRONG VALUES - B1" ); + END IF; + + A := (ID_B(FALSE), ID_B(TRUE), ID_B(TRUE), ID_B(FALSE)); + A := ( A(4) , A(3) , A(4) , TRUE ); + IF A /= ( FALSE , TRUE , FALSE, TRUE ) + THEN + FAILED( "WRONG VALUES - B2" ); + END IF; + + END; + + + DECLARE + A : ARRAY( INTEGER RANGE -4..4 ) OF BOOLEAN; + + BEGIN + A := (ID_B(FALSE), ID_B(FALSE), ID_B(FALSE), ID_B(FALSE), + ID_B(FALSE), ID_B(TRUE), ID_B(TRUE), + ID_B(TRUE), ID_B(TRUE)); + A(-4..0) := A(0..4); + IF A /= (FALSE, TRUE, TRUE, TRUE, TRUE,TRUE, TRUE, TRUE,TRUE) + THEN + FAILED( "WRONG VALUES - B3" ); + END IF; + + A := (ID_B(FALSE), ID_B(FALSE), ID_B(FALSE), ID_B(FALSE), + ID_B(TRUE), ID_B(TRUE), ID_B(TRUE), + ID_B(TRUE), ID_B(TRUE)); + A(0..4) := A(-4..0); + IF A /= (FALSE,FALSE,FALSE,FALSE,FALSE,FALSE,FALSE,FALSE,TRUE) + THEN + FAILED( "WRONG VALUES - B4" ); + END IF; + + END; + + + DECLARE + TYPE B_ARR IS ARRAY (INTEGER RANGE <>) OF BOOLEAN; + A : B_ARR (1..10); + + BEGIN + A := (ID_B(TRUE), ID_B(FALSE), ID_B(TRUE), ID_B(FALSE), + ID_B(TRUE), ID_B(FALSE), ID_B(TRUE), + ID_B(FALSE), ID_B(TRUE), ID_B(FALSE)); + A := FALSE & A(1..2) & A(1..2) & A(1..5); + IF A/=(FALSE,TRUE,FALSE,TRUE,FALSE,TRUE,FALSE,TRUE,FALSE,TRUE) + THEN + FAILED( "WRONG VALUES - B5" ); + END IF; + + A := (ID_B(TRUE), ID_B(FALSE), ID_B(TRUE), ID_B(FALSE), + ID_B(TRUE), ID_B(FALSE), ID_B(TRUE), + ID_B(FALSE), ID_B(TRUE), ID_B(FALSE)); + A := A(6..9) & A(8..9) & A(8..9) & FALSE & TRUE; + IF A/=(FALSE,TRUE,FALSE,TRUE,FALSE,TRUE,FALSE,TRUE,FALSE,TRUE) + THEN + FAILED( "WRONG VALUES - B6" ); + END IF; + + END; + + + ------------------------------------------------------------------- + -------------------- CHARACTER STRINGS -------------------------- + + DECLARE + A : STRING( 1..4 ); + + BEGIN + IF EQUAL (3,3) THEN + A := "ARGH"; + END IF; + A := ( 'Q' , A(1) , A(2) , A(1) ); + IF A /= "QARA" THEN + FAILED( "WRONG VALUES - C1" ); + END IF; + + IF EQUAL (3,3) THEN + A := "ARGH"; + END IF; + A := ( A(4) , A(3) , A(4) , 'X' ); + IF A /= "HGHX" THEN + FAILED( "WRONG VALUES - C2" ); + END IF; + + END; + + + DECLARE + A : STRING( 96..104 ); + + BEGIN + IF EQUAL (3,3) THEN + A := "APHRODITE"; + END IF; + A(96..100) := A(100..104); + IF A /= "ODITEDITE" THEN + FAILED( "WRONG VALUES - C3" ); + END IF; + + IF EQUAL (3,3) THEN + A := "APHRODITE"; + END IF; + A(100..104) := A(96..100) ; + IF A /= "APHRAPHRO" THEN + FAILED( "WRONG VALUES - C4" ); + END IF; + + END; + + + DECLARE + TYPE CH_ARR IS ARRAY (INTEGER RANGE <>) OF CHARACTER; + A : CH_ARR (1..9); + + BEGIN + IF EQUAL (3,3) THEN + A := "CAMBRIDGE"; + END IF; + A := 'S' & A(1..2) & A(1..2) & A(1..4); + IF A /= "SCACACAMB" THEN + FAILED( "WRONG VALUES - C5" ); + END IF; + + IF EQUAL (3,3) THEN + A := "CAMBRIDGE"; + END IF; + A := A(8..8) & A(6..8) & A(6..8) & "EA"; + IF A /= "GIDGIDGEA" THEN + FAILED( "WRONG VALUES - C6" ); + END IF; + + END; + + + RESULT; + + +END C52102C; diff --git a/gcc/testsuite/ada/acats/tests/c5/c52102d.ada b/gcc/testsuite/ada/acats/tests/c5/c52102d.ada new file mode 100644 index 000000000..fd4e41350 --- /dev/null +++ b/gcc/testsuite/ada/acats/tests/c5/c52102d.ada @@ -0,0 +1,307 @@ +-- C52102D.ADA + +-- Grant of Unlimited Rights +-- +-- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687, +-- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained +-- unlimited rights in the software and documentation contained herein. +-- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making +-- this public release, the Government intends to confer upon all +-- recipients unlimited rights equal to those held by the Government. +-- These rights include rights to use, duplicate, release or disclose the +-- released technical data and computer software in whole or in part, in +-- any manner and for any purpose whatsoever, and to have or permit others +-- to do so. +-- +-- DISCLAIMER +-- +-- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR +-- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED +-- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF 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 ASSIGNMENT OF OVERLAPPING SOURCE AND TARGET VARIABLES +-- (INCLUDING ARRAYS AND SLICES IN VARIOUS COMBINATIONS) SATISFIES +-- THE SEMANTICS OF "COPY" ASSIGNMENT WHEN INITIAL ASSIGNMENT VALUES +-- REQUIRE RUN-TIME EVALUATION. (THIS TEST IS IN TWO PARTS, +-- COVERING RESPECTIVELY STATIC AND DYNAMIC BOUNDS.) + +-- PART 2: DYNAMIC BOUNDS + + +-- RM 02/27/80 +-- SPS 2/18/83 +-- JBG 3/15/84 +-- JBG 6/9/84 +-- BHS 6/26/84 + +WITH REPORT; +PROCEDURE C52102D IS + + USE REPORT; + IDENT_INT_0 : INTEGER := IDENT_INT(0); + IDENT_INT_1 : INTEGER := IDENT_INT (1); + IDENT_INT_2 : INTEGER := IDENT_INT (2); + IDENT_INT_3 : INTEGER := IDENT_INT (3); + IDENT_INT_4 : INTEGER := IDENT_INT (4); + IDENT_INT_5 : INTEGER := IDENT_INT (5); + IDENT_INT_6 : INTEGER := IDENT_INT (6); + IDENT_INT_8 : INTEGER := IDENT_INT (8); + IDENT_INT_9 : INTEGER := IDENT_INT (9); + + FUNCTION ID_I (X : INTEGER) RETURN INTEGER RENAMES IDENT_INT; + FUNCTION ID_B (X : BOOLEAN) RETURN BOOLEAN RENAMES IDENT_BOOL; + +BEGIN + + + TEST( "C52102D" , "CHECK THAT THE ASSIGNMENT OF OVERLAPPING " & + "SOURCE AND TARGET VARIABLES (INCLUDING " & + "ARRAYS AND SLICES IN VARIOUS COMBINATIONS) " & + "SATISFIES THE SEMANTICS OF ""COPY"" " & + "ASSIGNMENT WHEN INITIAL ASSIGNMENT VALUES " & + "ARE DYNAMIC (PART 2: DYNAMIC BOUNDS)" ); + + ------------------------------------------------------------------- + -------------------- ARRAYS OF INTEGERS ------------------------- + + DECLARE + A : ARRAY( 1..IDENT_INT_4 ) OF INTEGER; + + BEGIN + A := ( ID_I(11), ID_I(12), ID_I(13), ID_I(14) ); + A := ( 1 , A(IDENT_INT_1) , A(IDENT_INT_2) , + A(IDENT_INT_1) ); + IF A /= ( 1 , 11 , 12 , 11 ) THEN + FAILED( "WRONG VALUES - I1" ); + END IF; + + A := ( ID_I(11), ID_I(12), ID_I(13), ID_I(14) ); + A := ( A(IDENT_INT_4) , A(IDENT_INT_3) , + A(IDENT_INT_4) , 1 ); + IF A /= ( 14 , 13 , 14 , 1 ) THEN + FAILED( "WRONG VALUES - I2" ); + END IF; + + END; + + + DECLARE + A : ARRAY( -4..IDENT_INT_4 ) OF INTEGER; + + BEGIN + A := ( -ID_I(4), -ID_I(3), -ID_I(2), -ID_I(1), + ID_I(100), ID_I(1), ID_I(2), ID_I(3), ID_I(4)); + A(-4..IDENT_INT_0) := A(IDENT_INT_0..4); + IF A /= ( 100 , 1 , 2 , 3 , 4 , 1 , 2 , 3 , 4 ) + THEN + FAILED( "WRONG VALUES - I3" ); + END IF; + + A := ( -ID_I(4), -ID_I(3), -ID_I(2), -ID_I(1), + ID_I(100), ID_I(1), ID_I(2), ID_I(3), ID_I(4)); + A(IDENT_INT_0..4) := A(-4..IDENT_INT_0); + IF A /= ( -4 , -3 , -2 , -1 , -4 , -3 , -2 , -1 , 100 ) + THEN + FAILED( "WRONG VALUES - I4" ); + END IF; + + END; + + + DECLARE + TYPE INT_ARR IS ARRAY (INTEGER RANGE <>) OF INTEGER; + A : INT_ARR (1..10); + + BEGIN + A := ( ID_I(1), ID_I(2), ID_I(3), ID_I(4), ID_I(5), + ID_I(6), ID_I(7), ID_I(8), ID_I(9), ID_I(10)); + A := 0 & A(IDENT_INT_1..IDENT_INT_2) & + A(IDENT_INT_1..IDENT_INT_2) & + A(IDENT_INT_1..IDENT_INT_5); + IF A /= ( 0 , 1 , 2 , 1 , 2 , 1 , 2 , 3 , 4 , 5 ) + THEN + FAILED( "WRONG VALUES - I5" ); + END IF; + + A := ( ID_I(1), ID_I(2), ID_I(3), ID_I(4), ID_I(5), + ID_I(6), ID_I(7), ID_I(8), ID_I(9), ID_I(10)); + A := A(IDENT_INT_6..IDENT_INT_9) & + A(IDENT_INT_8..IDENT_INT_9) & + A(IDENT_INT_8..IDENT_INT_9) & 0 & 0; + IF A /= ( 6 , 7 , 8 , 9 , 8 , 9 , 8 , 9 , 0 , 0 ) + THEN + FAILED( "WRONG VALUES - I6" ); + END IF; + + END; + + + ------------------------------------------------------------------- + -------------------- ARRAYS OF BOOLEANS ------------------------- + + DECLARE + A : ARRAY( 1..4 ) OF BOOLEAN; + + BEGIN + A := (ID_B(FALSE), ID_B(TRUE), ID_B(TRUE), ID_B(FALSE)); + A := ( TRUE , A(IDENT_INT_1) , A(IDENT_INT_2) , + A(IDENT_INT_1) ); + IF A /= ( TRUE ,FALSE , TRUE , FALSE ) + THEN + FAILED( "WRONG VALUES - B1" ); + END IF; + + A := (ID_B(FALSE), ID_B(TRUE), ID_B(TRUE), ID_B(FALSE)); + A := ( A(IDENT_INT_4) , A(IDENT_INT_3) , + A(IDENT_INT_4) , TRUE ); + IF A /= ( FALSE , TRUE , FALSE, TRUE ) + THEN + FAILED( "WRONG VALUES - B2" ); + END IF; + + END; + + + DECLARE + A : ARRAY( -IDENT_INT_4..4 ) OF BOOLEAN; + + BEGIN + A := (ID_B(FALSE), ID_B(FALSE), ID_B(FALSE), ID_B(FALSE), + ID_B(FALSE), ID_B(TRUE), ID_B(TRUE), + ID_B(TRUE), ID_B(TRUE)); + A(-IDENT_INT_4..IDENT_INT_0) := A(IDENT_INT_0..4); + IF A /= (FALSE, TRUE, TRUE, TRUE, TRUE,TRUE, TRUE, TRUE,TRUE) + THEN + FAILED( "WRONG VALUES - B3" ); + END IF; + + A := (ID_B(FALSE), ID_B(FALSE), ID_B(FALSE), ID_B(FALSE), + ID_B(TRUE), ID_B(TRUE), ID_B(TRUE), + ID_B(TRUE), ID_B(TRUE)); + A(IDENT_INT_0..4) := A(-4..IDENT_INT_0); + IF A /= (FALSE,FALSE,FALSE,FALSE,FALSE,FALSE,FALSE,FALSE,TRUE) + THEN + FAILED( "WRONG VALUES - B4" ); + END IF; + + END; + + + DECLARE + TYPE B_ARR IS ARRAY (INTEGER RANGE <>) OF BOOLEAN; + A : B_ARR (1..10); + + BEGIN + A := (ID_B(TRUE), ID_B(FALSE), ID_B(TRUE), ID_B(FALSE), + ID_B(TRUE), ID_B(FALSE), ID_B(TRUE), + ID_B(FALSE), ID_B(TRUE), ID_B(FALSE)); + A := FALSE & A(IDENT_INT_1..IDENT_INT_2) & + A(IDENT_INT_1..IDENT_INT_2) & + A(IDENT_INT_1..IDENT_INT_5); + IF A/=(FALSE,TRUE,FALSE,TRUE,FALSE,TRUE,FALSE,TRUE,FALSE,TRUE) + THEN + FAILED( "WRONG VALUES - B5" ); + END IF; + + A := (ID_B(TRUE), ID_B(FALSE), ID_B(TRUE), ID_B(FALSE), + ID_B(TRUE), ID_B(FALSE), ID_B(TRUE), + ID_B(FALSE), ID_B(TRUE), ID_B(FALSE)); + A := A(IDENT_INT_6..IDENT_INT_9) & + A(IDENT_INT_8..IDENT_INT_9) & + A(IDENT_INT_8..IDENT_INT_9) & FALSE & TRUE; + IF A/=(FALSE,TRUE,FALSE,TRUE,FALSE,TRUE,FALSE,TRUE,FALSE,TRUE) + THEN + FAILED( "WRONG VALUES - B6" ); + END IF; + + END; + + + ------------------------------------------------------------------- + -------------------- CHARACTER STRINGS -------------------------- + + DECLARE + A : STRING( 1..4 ); + + BEGIN + IF EQUAL (3,3) THEN + A := "ARGH"; + END IF; + A := ( 'Q' , A(IDENT_INT_1) , A(IDENT_INT_2) , + A(IDENT_INT_1) ); + IF A /= "QARA" THEN + FAILED( "WRONG VALUES - C1" ); + END IF; + + IF EQUAL (3,3) THEN + A := "ARGH"; + END IF; + A := ( A(IDENT_INT_4) , A(IDENT_INT_3) , + A(IDENT_INT_4) , 'X' ); + IF A /= "HGHX" THEN + FAILED( "WRONG VALUES - C2" ); + END IF; + + END; + + + DECLARE + A : STRING( IDENT_INT(96)..104 ); + + BEGIN + IF EQUAL (3,3) THEN + A := "APHRODITE"; + END IF; + A(IDENT_INT(96)..IDENT_INT(100)) := A(IDENT_INT(100).. + IDENT_INT(104)); + IF A /= "ODITEDITE" THEN + FAILED( "WRONG VALUES - C3" ); + END IF; + + IF EQUAL (3,3) THEN + A := "APHRODITE"; + END IF; + A(IDENT_INT(100)..IDENT_INT(104)) := A(IDENT_INT(96).. + IDENT_INT(100)) ; + IF A /= "APHRAPHRO" THEN + FAILED( "WRONG VALUES - C4" ); + END IF; + + END; + + + DECLARE + TYPE CH_ARR IS ARRAY (INTEGER RANGE <>) OF CHARACTER; + A : CH_ARR (IDENT_INT_1..9); + + BEGIN + IF EQUAL (3,3) THEN + A := "CAMBRIDGE"; + END IF; + A := 'S' & A(IDENT_INT_1..IDENT_INT_2) & + A(IDENT_INT_1..IDENT_INT_2) & + A(IDENT_INT_1..IDENT_INT_4); + IF A /= "SCACACAMB" THEN + FAILED( "WRONG VALUES - C5" ); + END IF; + + IF EQUAL (3,3) THEN + A := "CAMBRIDGE"; + END IF; + A := A(IDENT_INT_8..IDENT_INT_8) & + A(IDENT_INT_6..IDENT_INT_8) & + A(IDENT_INT_6..IDENT_INT_8) & "EA"; + IF A /= "GIDGIDGEA" THEN + FAILED( "WRONG VALUES - C6" ); + END IF; + + END; + + + RESULT; + + +END C52102D; diff --git a/gcc/testsuite/ada/acats/tests/c5/c52103a.ada b/gcc/testsuite/ada/acats/tests/c5/c52103a.ada new file mode 100644 index 000000000..f8fca51bc --- /dev/null +++ b/gcc/testsuite/ada/acats/tests/c5/c52103a.ada @@ -0,0 +1,385 @@ +-- C52103A.ADA + +-- Grant of Unlimited Rights +-- +-- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687, +-- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained +-- unlimited rights in the software and documentation contained herein. +-- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making +-- this public release, the Government intends to confer upon all +-- recipients unlimited rights equal to those held by the Government. +-- These rights include rights to use, duplicate, release or disclose the +-- released technical data and computer software in whole or in part, in +-- any manner and for any purpose whatsoever, and to have or permit others +-- to do so. +-- +-- DISCLAIMER +-- +-- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR +-- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED +-- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF 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 LENGTHS MUST MATCH IN ARRAY AND SLICE ASSIGNMENTS. +-- MORE SPECIFICALLY, TEST THAT ARRAY ASSIGNMENTS WITH MATCHING +-- LENGTHS DO NOT CAUSE CONSTRAINT_ERROR TO BE RAISED AND +-- ARE PERFORMED CORRECTLY. +-- (OVERLAPS BETWEEN THE OPERANDS OF THE ASSIGNMENT STATEMENT +-- ARE TREATED ELSEWHERE.) + +-- DIVISION A : STATICALLY-DETERMINABLE NON-NULL LENGTHS. + + +-- RM 07/20/81 +-- SPS 2/18/83 + +WITH REPORT; +PROCEDURE C52103A IS + + USE REPORT ; + +BEGIN + + TEST( "C52103A" , "CHECK THAT IN ARRAY ASSIGNMENTS AND IN SLICE" & + " ASSIGNMENTS THE LENGTHS MUST MATCH" ); + + + -- IN THIS TEST WE CAN'T USE AGGREGATE ASSIGNMENT (EXCEPT WHEN + -- THE AGGREGATES ARE STRING LITERALS); THEREFORE: + -- + -- (1) ARRAYS WILL BE INITIALIZED BY INDIVIDUAL ASSIGNMENTS; + -- (2) CAN'T USE NON-NULL CONSTANT ARRAYS. + + + -- WE ASSUME THAT IN AN ARRAY_TYPE_DEFINITION THE INDEX PORTION + -- AND THE COMPONENT_TYPE PORTION ARE FUNCTIONALLY ORTHOGONAL + -- ALSO AT THE IMPLEMENTATION LEVEL, I.E. THAT THE CORRECTNESS + -- OF THE ACCESSING MECHANISM FOR ARRAYS DOES NOT DEPEND ON + -- COMPONENT_TYPE. ACCORDINGLY WE ARE TESTING FOR SOME BUT + -- NOT ALL KINDS OF COMPONENT_TYPE. (COMPONENT_TYPES INCLUDED: + -- INTEGER , CHARACTER , BOOLEAN .) + + + -- CASES DISTINGUISHED: ( 8 SELECTED CASES ARE IMPLEMENTED) + -- + -- ( THE SELECTIONS ARE 7 , 8 , 9 , + -- AND PRECISELY 5 CASES FROM THE + -- TWO 5-CASE SERIES 2-3-4-5-6 AND + -- 10-11-12-13-14) + -- + -- ( IN THE CURRENT DIVISION, THE 5 + -- FLOATING SELECTIONS ARE 2-11-4- + -- -13-6 ; THUS THE 8 SELECTIONS ARE + -- 2-11-4-13-6-7-8-9 (IN THIS ORDER) + -- .) + -- + -- + -- ( EACH DIVISION COMPRISES 3 FILES, + -- COVERING RESPECTIVELY THE FIRST + -- 3 , NEXT 2 , AND LAST 3 OF THE 8 + -- SELECTIONS FOR THE DIVISION.) + -- + -- + -- (1) ARRAY OBJECTS DECLARED IN THE SAME DECLARATION. + -- (TWO-DIMENSIONAL; NON-CONSTRAINABLE TYPEMARK.) + -- + -- (THIS WILL BE THE ONLY CASE INVOLVING OBJECTS DECLARED + -- IN THE SAME DECLARATION.) + -- + -- + -- (2) MULTIDIMENSIONAL ARRAY OBJECTS WHOSE TYPEMARKS WERE + -- DEFINED WITHOUT EVER USING THE "BOX" COMPOUND SYMBOL. + -- (TWO-DIMENSIONAL ARRAYS OF INTEGERS.) + -- + -- (SLICING IS ILLEGAL; SINCE IN THIS TEST WE ARE NEVER + -- USING AGGREGATES + -- (EXCEPT FOR ONE-DIMENSIONAL ARRAYS OF CHARACTERS; + -- SEE (5) ) + -- AND WE ARE NOT USING CONVERSION-TO-CONSTRAINED-TYPEMARKS + -- (AS IN T1(ARR) , WHERE ARR IS AN ARRAY + -- OBJECT AND T1 IS AN ARRAY TYPEMARK SIMILAR + -- -- AS MORE PRECISELY SPECIFIED IN RM 4.6(B) -- + -- TO THE TYPEMARK OF ARR ), + -- THE ARRAY ASSIGNMENT CANNOT INVOLVE ANY SLIDING, + -- AND THE TYPEMARKS ARE ESSENTIALLY THE SAME.) + -- + -- + -- (3) UNSLICED ONE-DIMENSIONAL ARRAY OBJECTS WHOSE TYPEMARKS + -- WERE DEFINED WITHOUT EVER USING THE "BOX" SYMBOL + -- AND FOR WHICH THE COMPONENT TYPE IS NOT 'CHARACTER' . + -- ((ONE-DIMENSIONAL) ARRAYS OF INTEGERS.) + -- + -- (SINCE WE ARE NOT USING AGGREGATES + -- AND WE ARE NOT USING CONVERSION-TO-CONSTRAINED-TYPEMARKS, + -- THE ARRAY ASSIGNMENT CANNOT INVOLVE ANY SLIDING, + -- AND THE TYPEMARKS ARE ESSENTIALLY THE SAME.) + -- + -- + -- (4) SLICED ONE-DIMENSIONAL ARRAY OBJECTS WHOSE TYPEMARKS + -- WERE DEFINED WITHOUT EVER USING THE "BOX" SYMBOL + -- AND FOR WHICH THE COMPONENT TYPE IS NOT 'CHARACTER' . + -- ((ONE-DIMENSIONAL) ARRAYS OF INTEGERS.) + -- + -- (THE ASSIGNMENT MAY REQUIRE SLIDING.) + -- + -- (MOST SUBSEQUENT SUBCASES IN THIS TEST (OTHER THAN NULL + -- ASSIGNMENTS) WILL INVOLVE SLIDING; WE ASSUME THAT + -- SUBCASES WHICH WORK IN CONJUNCTION WITH SLIDING WORK + -- ALSO WHEN NO SLIDING IS INVOLVED.) + -- + -- + -- (5) UNSLICED ONE-DIMENSIONAL ARRAY OBJECTS WHOSE TYPEMARKS + -- WERE DEFINED WITHOUT EVER USING THE "BOX" SYMBOL + -- AND FOR WHICH THE COMPONENT TYPE IS 'CHARACTER' . + -- + -- (STRING LITERALS ARE THE ONLY AGGREGATES WE ARE USING + -- IN THIS TEST. TO FORCE SLIDING, THE LOWER LIMIT IMPLIED + -- BY THE TYPEMARK WILL NOT BE 1 .) + -- + -- + -- (6) SLICED ONE-DIMENSIONAL ARRAY OBJECTS WHOSE TYPEMARKS + -- WERE DEFINED WITHOUT EVER USING THE "BOX" SYMBOL + -- AND FOR WHICH THE COMPONENT TYPE IS 'CHARACTER' . + -- + -- + -- (7) UNSLICED OBJECTS OF THE PREDEFINED TYPE 'STRING' (BY + -- THEMSELVES). + -- + -- + -- (8) SLICED OBJECTS OF THE PREDEFINED TYPE 'STRING' , WITH + -- STRING LITERALS. + -- + -- + -- (9) SLICED OBJECTS OF THE PREDEFINED TYPE 'STRING' (BY + -- THEMSELVES). + -- + -- + -- (-) CONSTRAINABLE TYPES: ONLY SUBTESTS 2, 3, 4, 5, 6 + -- WILL BE REPLICATED -- AS SUBTESTS 10, 11, 12, 13, 14 . + -- + -- + -- (10) MULTIDIMENSIONAL ARRAY OBJECTS WHOSE TYPEMARKS WERE + -- DEFINED USING THE "BOX" COMPOUND SYMBOL. + -- (TWO-DIMENSIONAL ARRAYS OF INTEGERS.) + -- + -- + -- (11) UNSLICED ONE-DIMENSIONAL ARRAY OBJECTS WHOSE TYPEMARKS + -- WERE DEFINED USING THE "BOX" SYMBOL + -- AND FOR WHICH THE COMPONENT TYPE IS NOT 'CHARACTER' . + -- ((ONE-DIMENSIONAL) ARRAYS OF INTEGERS.) + -- + -- + -- (12) SLICED ONE-DIMENSIONAL ARRAY OBJECTS WHOSE TYPEMARKS + -- WERE DEFINED USING THE "BOX" SYMBOL + -- AND FOR WHICH THE COMPONENT TYPE IS NOT 'CHARACTER' . + -- ((ONE-DIMENSIONAL) ARRAYS OF BOOLEANS.) + -- + -- + -- (13) UNSLICED ONE-DIMENSIONAL ARRAY OBJECTS WHOSE TYPEMARKS + -- WERE DEFINED USING THE "BOX" SYMBOL + -- AND FOR WHICH THE COMPONENT TYPE IS 'CHARACTER' . + -- + -- (STRING LITERALS ARE THE ONLY AGGREGATES WE ARE USING + -- IN THIS TEST. TO FORCE SLIDING, THE LOWER LIMIT IMPLIED + -- BY THE TYPEMARK WILL NOT BE 1 .) + -- + -- + -- (14) SLICED ONE-DIMENSIONAL ARRAY OBJECTS WHOSE TYPEMARKS + -- WERE DEFINED USING THE "BOX" SYMBOL + -- AND FOR WHICH THE COMPONENT TYPE IS 'CHARACTER' . + -- + -- + -- + -- (-) SPECIAL CASES: NULL ARRAYS....... TREATED IN DIVISION B. + -- SUPERLONG ARRAYS.. (TREATED FOR DYNAMIC + -- ARRAYS ONLY, + -- DIVISIONS C AND D .) + -- + -- + -- (-) THE DYNAMIC-ARRAY COUNTERPARTS OF THESE TESTS ARE IN DI- + -- VISIONS C (FOR NON-NULL ARRAYS) AND D (FOR NULL ARRAYS). + -- + -- + + + ------------------------------------------------------------------- + + -- (2) MULTIDIMENSIONAL ARRAY OBJECTS WHOSE TYPEMARKS WERE + -- DEFINED WITHOUT EVER USING THE "BOX" COMPOUND SYMBOL. + -- (TWO-DIMENSIONAL ARRAYS OF INTEGERS.) + + DECLARE + + TYPE TA21 IS ARRAY( INTEGER RANGE 1..5 , INTEGER RANGE 0..7 + ) OF INTEGER ; + + SUBTYPE TA22 IS TA21 ; + + ARR21 : TA21 ; + ARR22 : TA22 ; + + BEGIN + + -- INITIALIZATION OF RHS ARRAY: + + FOR I IN 1..5 LOOP + + FOR J IN 0..7 LOOP + ARR21( I , J ) := I * I * J ; + END LOOP; + + END LOOP; + + + -- ARRAY ASSIGNMENT: + + ARR22 := ARR21 ; + + -- CHECKING THE VALUES AFTER THE ARRAY ASSIGNMENT: + + FOR I IN 1..5 LOOP + + FOR J IN 0..7 LOOP + + IF ARR22( I , J ) /= ( I-0 ) * ( I-0 ) * ( J-0 ) + THEN + FAILED( "ARRAY ASSIGNMENT NOT CORRECT" ); + END IF; + + END LOOP; + + END LOOP; + + + EXCEPTION + + WHEN OTHERS => + FAILED( "EXCEPTION RAISED - SUBTEST 2" ); + + END ; + + + ------------------------------------------------------------------- + + -- (11) UNSLICED ONE-DIMENSIONAL ARRAY OBJECTS WHOSE TYPEMARKS + -- WERE DEFINED USING THE "BOX" SYMBOL + -- AND FOR WHICH THE COMPONENT TYPE IS NOT 'CHARACTER' . + -- ((ONE-DIMENSIONAL) ARRAYS OF INTEGERS.) + + DECLARE + + TYPE TABOX1 IS ARRAY( INTEGER RANGE <> ) OF INTEGER ; + + SUBTYPE TABOX11 IS TABOX1( 1..5 ) ; + + ARRX11 : TABOX11 ; + ARRX12 : TABOX1( 5..9 ); + + BEGIN + + -- INITIALIZATION OF RHS ARRAY: + + FOR I IN 1..5 LOOP + ARRX11( I ) := I * I ; + END LOOP; + + + -- ARRAY ASSIGNMENT: + + ARRX12 := ARRX11 ; + + -- CHECKING THE VALUES AFTER THE ARRAY ASSIGNMENT: + + FOR I IN 5..9 LOOP + + IF ARRX12( I ) /= ( I-4 ) * ( I-4 ) + THEN + FAILED( "ARRAY ASSIGNMENT NOT CORRECT (11)" ); + END IF; + + END LOOP; + + + EXCEPTION + + WHEN OTHERS => + FAILED( "EXCEPTION RAISED - SUBTEST 11" ); + + END ; + + + ------------------------------------------------------------------- + + -- (4) SLICED ONE-DIMENSIONAL ARRAY OBJECTS WHOSE TYPEMARKS + -- WERE DEFINED WITHOUT EVER USING THE "BOX" SYMBOL + -- AND FOR WHICH THE COMPONENT TYPE IS NOT 'CHARACTER' . + -- ((ONE-DIMENSIONAL) ARRAYS OF BOOLEANS.) + + DECLARE + + TYPE TA42 IS ARRAY( INTEGER RANGE 1..5 ) OF BOOLEAN ; + + SUBTYPE TA41 IS TA42 ; + + ARR41 : TA41 ; + ARR42 : TA42 ; + + BEGIN + + -- INITIALIZATION OF RHS ARRAY: + + FOR I IN 1..5 LOOP + ARR41( I ) := FALSE ; -- VALUES WILL BE: F T F F T + END LOOP; + + ARR41(2) := TRUE ; + + ARR41(5) := TRUE ; -- RHS VALUES ARE: F T F F T + + + -- INITIALIZATION OF UNUSED COMPONENT OF LHS ARRAY: + + ARR42( 1 ) := TRUE ; + + + -- SLICE ASSIGNMENT: + + ARR42(2..5) := ARR41(1..4) ; + + + -- CHECKING THE VALUES AFTER THE SLICE ASSIGNMENT: + + FOR I IN 2..5 LOOP + + IF ARR42( I ) /= FALSE AND I /= 3 + THEN + FAILED( "SLICE ASSIGNMENT NOT CORRECT (VALUES)" ); + ELSIF ARR42( I ) /= TRUE AND I = 3 + THEN + FAILED( "SLICE ASSIGNMENT NOT CORRECT (VALUES)" ); + END IF; + + END LOOP; + + IF ARR42( 1 ) /= TRUE + THEN + FAILED( "SLICE ASSIGNMENT NOT CORRECT (SLIDING)" ); + END IF; + + EXCEPTION + + WHEN OTHERS => + FAILED( "EXCEPTION RAISED - SUBTEST 4" ); + + END ; + + + ------------------------------------------------------------------- + + + RESULT ; + + +END C52103A; diff --git a/gcc/testsuite/ada/acats/tests/c5/c52103b.ada b/gcc/testsuite/ada/acats/tests/c5/c52103b.ada new file mode 100644 index 000000000..678ef5dbb --- /dev/null +++ b/gcc/testsuite/ada/acats/tests/c5/c52103b.ada @@ -0,0 +1,139 @@ +-- C52103B.ADA + +-- Grant of Unlimited Rights +-- +-- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687, +-- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained +-- unlimited rights in the software and documentation contained herein. +-- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making +-- this public release, the Government intends to confer upon all +-- recipients unlimited rights equal to those held by the Government. +-- These rights include rights to use, duplicate, release or disclose the +-- released technical data and computer software in whole or in part, in +-- any manner and for any purpose whatsoever, and to have or permit others +-- to do so. +-- +-- DISCLAIMER +-- +-- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR +-- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED +-- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF 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 LENGTHS MUST MATCH IN ARRAY AND SLICE ASSIGNMENTS. +-- MORE SPECIFICALLY, TEST THAT ARRAY ASSIGNMENTS WITH MATCHING +-- LENGTHS DO NOT CAUSE CONSTRAINT_ERROR TO BE RAISED AND +-- ARE PERFORMED CORRECTLY. +-- (OVERLAPS BETWEEN THE OPERANDS OF THE ASSIGNMENT STATEMENT +-- ARE TREATED ELSEWHERE.) + +-- THIS IS THE SECOND FILE IN +-- DIVISION A : STATICALLY-DETERMINABLE NON-NULL LENGTHS. + + +-- RM 07/20/81 +-- SPS 2/18/83 + +WITH REPORT; +PROCEDURE C52103B IS + + USE REPORT ; + +BEGIN + + TEST( "C52103B" , "CHECK THAT IN ARRAY ASSIGNMENTS AND IN SLICE" & + " ASSIGNMENTS THE LENGTHS MUST MATCH" ); + + + -- ( EACH DIVISION COMPRISES 3 FILES, + -- COVERING RESPECTIVELY THE FIRST + -- 3 , NEXT 2 , AND LAST 3 OF THE 8 + -- SELECTIONS FOR THE DIVISION.) + + + ------------------------------------------------------------------- + + -- (13) UNSLICED ONE-DIMENSIONAL ARRAY OBJECTS WHOSE TYPEMARKS + -- WERE DEFINED USING THE "BOX" SYMBOL + -- AND FOR WHICH THE COMPONENT TYPE IS 'CHARACTER' . + + DECLARE + + TYPE TABOX3 IS ARRAY( INTEGER RANGE <> ) OF CHARACTER ; + + ARRX31 : TABOX3( 11..15 ); + + BEGIN + + + -- ARRAY ASSIGNMENT (WITH STRING AGGREGATE): + + ARRX31 := "QUINC" ; -- "QUINC"(1..5) SLIDES TO 11..15 + + + -- CHECKING THE VALUES AFTER THE ASSIGNMENT: + + IF ARRX31 /= "QUINC" OR + ARRX31( 11..15 ) /= "QUINC" + THEN + FAILED( "ARRAY ASSIGNMENT NOT CORRECT (13)" ); + END IF; + + EXCEPTION + + WHEN OTHERS => + FAILED( "EXCEPTION RAISED - SUBTEST 13" ); + + END ; + + + ------------------------------------------------------------------- + + -- (6) SLICED ONE-DIMENSIONAL ARRAY OBJECTS WHOSE TYPEMARKS + -- WERE DEFINED WITHOUT EVER USING THE "BOX" SYMBOL + -- AND FOR WHICH THE COMPONENT TYPE IS 'CHARACTER' . + -- + + DECLARE + + TYPE TA61 IS ARRAY( INTEGER RANGE 11..15 ) OF CHARACTER ; + + ARR61 : TA61 ; + + BEGIN + + -- INITIALIZATION OF UNUSED COMPONENT OF LHS ARRAY: + + ARR61( 11..11 ) := "Q" ; + + + -- SLICE ASSIGNMENT: + + ARR61( 12..15 ) := "UINC" ; -- "UINC"(1..4) SLIDES TO 12..15 + + + -- CHECKING THE VALUES AFTER THE SLICE ASSIGNMENT: + + IF ARR61 /= "QUINC" OR + ARR61( 11..15 ) /= "QUINC" + THEN + FAILED( "SLICE ASSIGNMENT NOT CORRECT (6)" ); + END IF; + + EXCEPTION + + WHEN OTHERS => + FAILED( "EXCEPTION RAISED - SUBTEST 6" ); + + END ; + + + ------------------------------------------------------------------- + + + RESULT ; + + +END C52103B; diff --git a/gcc/testsuite/ada/acats/tests/c5/c52103c.ada b/gcc/testsuite/ada/acats/tests/c5/c52103c.ada new file mode 100644 index 000000000..fb122a76e --- /dev/null +++ b/gcc/testsuite/ada/acats/tests/c5/c52103c.ada @@ -0,0 +1,178 @@ +-- C52103C.ADA + +-- Grant of Unlimited Rights +-- +-- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687, +-- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained +-- unlimited rights in the software and documentation contained herein. +-- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making +-- this public release, the Government intends to confer upon all +-- recipients unlimited rights equal to those held by the Government. +-- These rights include rights to use, duplicate, release or disclose the +-- released technical data and computer software in whole or in part, in +-- any manner and for any purpose whatsoever, and to have or permit others +-- to do so. +-- +-- DISCLAIMER +-- +-- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR +-- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED +-- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF 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 LENGTHS MUST MATCH IN ARRAY AND SLICE ASSIGNMENTS. +-- MORE SPECIFICALLY, TEST THAT ARRAY ASSIGNMENTS WITH MATCHING +-- LENGTHS DO NOT CAUSE CONSTRAINT_ERROR TO BE RAISED AND +-- ARE PERFORMED CORRECTLY. +-- (OVERLAPS BETWEEN THE OPERANDS OF THE ASSIGNMENT STATEMENT +-- ARE TREATED ELSEWHERE.) + +-- THIS IS THE THIRD FILE IN +-- DIVISION A : STATICALLY-DETERMINABLE NON-NULL LENGTHS. + + +-- RM 07/20/81 +-- SPS 3/22/83 + + +WITH REPORT; + + +PROCEDURE C52103C IS + + USE REPORT ; + +BEGIN + + TEST( "C52103C" , "CHECK THAT IN ARRAY ASSIGNMENTS AND IN SLICE" & + " ASSIGNMENTS THE LENGTHS MUST MATCH" ); + + + -- ( EACH DIVISION COMPRISES 3 FILES, + -- COVERING RESPECTIVELY THE FIRST + -- 3 , NEXT 2 , AND LAST 3 OF THE 8 + -- SELECTIONS FOR THE DIVISION.) + + + ------------------------------------------------------------------- + + -- (7) UNSLICED OBJECTS OF THE PREDEFINED TYPE 'STRING' (BY + -- THEMSELVES). + + DECLARE + + ARR71 : STRING( 1..5 ) := "ABCDE" ; + ARR72 : STRING( 5..9 ) := "FGHIJ" ; + + BEGIN + + + -- STRING ASSIGNMENT: + + ARR72 := ARR71 ; + + + -- CHECKING THE VALUES AFTER THE STRING ASSIGNMENT: + + IF ARR72 /= "ABCDE" + THEN + FAILED( "STRING ASSIGNMENT NOT CORRECT (7)" ); + END IF; + + EXCEPTION + + WHEN OTHERS => + FAILED( "EXCEPTION RAISED - SUBTEST 7" ); + + END ; + + + ------------------------------------------------------------------- + + -- (8) SLICED OBJECTS OF THE PREDEFINED TYPE 'STRING' , WITH + -- STRING LITERALS. + -- + + DECLARE + + ARR82 : STRING( 5..9 ) ; + + BEGIN + + + -- INITIALIZATION OF UNUSED COMPONENT OF LHS ARRAY: + + ARR82( 5..5 ) := "Q" ; + + + -- STRING LITERAL ASSIGNMENT: + + ARR82( 5..9 )( 6..9 ) := "BCDE" ; + + + -- CHECKING THE VALUES AFTER THE SLICE ASSIGNMENT: + + IF ARR82 /= "QBCDE" OR + ARR82( 5..9 ) /= "QBCDE" + THEN + FAILED( "SLICE ASSIGNMENT NOT CORRECT (8)" ); + END IF; + + EXCEPTION + + WHEN OTHERS => + FAILED( "EXCEPTION RAISED - SUBTEST 8" ); + + END ; + + ------------------------------------------------------------------- + + -- (9) SLICED OBJECTS OF THE PREDEFINED TYPE 'STRING' (BY + -- THEMSELVES). + -- + + DECLARE + + SUBTYPE TA92 IS STRING( 5..9 ) ; + + ARR91 : STRING( 1..5 ) := "ABCDE" ; + ARR92 : TA92 ; + + BEGIN + + + -- INITIALIZATION OF UNUSED COMPONENT OF LHS ARRAY: + + ARR92( 5..5 ) := "Q" ; + + + -- STRING SLICE ASSIGNMENT: + + ARR92( 5..9 )( 6..9 ) := ARR91( 1..5 )(2..5 )( 2..5 ) ; + + + -- CHECKING THE VALUES AFTER THE SLICE ASSIGNMENT: + + IF ARR92 /= "QBCDE" OR + ARR92( 5..9 ) /= "QBCDE" + THEN + FAILED( "SLICE ASSIGNMENT NOT CORRECT (9)" ); + END IF; + + EXCEPTION + + WHEN OTHERS => + FAILED( "EXCEPTION RAISED - SUBTEST 9" ); + + END ; + + + ------------------------------------------------------------------- + + + RESULT ; + + +END C52103C; diff --git a/gcc/testsuite/ada/acats/tests/c5/c52103f.ada b/gcc/testsuite/ada/acats/tests/c5/c52103f.ada new file mode 100644 index 000000000..fad061697 --- /dev/null +++ b/gcc/testsuite/ada/acats/tests/c5/c52103f.ada @@ -0,0 +1,338 @@ +-- C52103F.ADA + +-- Grant of Unlimited Rights +-- +-- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687, +-- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained +-- unlimited rights in the software and documentation contained herein. +-- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making +-- this public release, the Government intends to confer upon all +-- recipients unlimited rights equal to those held by the Government. +-- These rights include rights to use, duplicate, release or disclose the +-- released technical data and computer software in whole or in part, in +-- any manner and for any purpose whatsoever, and to have or permit others +-- to do so. +-- +-- DISCLAIMER +-- +-- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR +-- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED +-- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF 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 LENGTHS MUST MATCH IN ARRAY AND SLICE ASSIGNMENTS. +-- MORE SPECIFICALLY, TEST THAT ARRAY ASSIGNMENTS WITH MATCHING +-- LENGTHS DO NOT CAUSE CONSTRAINT_ERROR TO BE RAISED AND +-- ARE PERFORMED CORRECTLY. +-- (OVERLAPS BETWEEN THE OPERANDS OF THE ASSIGNMENT STATEMENT +-- ARE TREATED ELSEWHERE.) + +-- DIVISION B : STATICALLY-DETERMINABLE NULL LENGTHS. + + +-- RM 07/20/81 +-- SPS 3/22/83 + + +WITH REPORT; +PROCEDURE C52103F IS + + USE REPORT ; + +BEGIN + + TEST( "C52103F" , "CHECK THAT IN ARRAY ASSIGNMENTS AND IN SLICE" & + " ASSIGNMENTS THE LENGTHS MUST MATCH" ); + + + -- IN THIS TEST WE CAN'T USE AGGREGATE ASSIGNMENT (EXCEPT WHEN + -- THE AGGREGATES ARE STRING LITERALS); THEREFORE: + -- + -- (1) ARRAYS WILL BE INITIALIZED BY INDIVIDUAL ASSIGNMENTS; + -- (2) CAN'T USE NON-NULL CONSTANT ARRAYS. + + + -- WE ASSUME THAT IN AN ARRAY_TYPE_DEFINITION THE INDEX PORTION + -- AND THE COMPONENT_TYPE PORTION ARE FUNCTIONALLY ORTHOGONAL + -- ALSO AT THE IMPLEMENTATION LEVEL, I.E. THAT THE CORRECTNESS + -- OF THE ACCESSING MECHANISM FOR ARRAYS DOES NOT DEPEND ON + -- COMPONENT_TYPE. ACCORDINGLY WE ARE TESTING FOR SOME BUT + -- NOT ALL KINDS OF COMPONENT_TYPE. (COMPONENT_TYPES INCLUDED: + -- INTEGER , CHARACTER , BOOLEAN .) + + + -- CASES DISTINGUISHED: ( 8 SELECTED CASES ARE IMPLEMENTED) + -- + -- ( THE SELECTIONS ARE 7 , 8 , 9 , + -- AND PRECISELY 5 CASES FROM THE + -- TWO 5-CASE SERIES 2-3-4-5-6 AND + -- 10-11-12-13-14) + -- + -- ( IN THE CURRENT DIVISION, THE 5 + -- FLOATING SELECTIONS ARE 10-3-12- + -- -5-14 ; THUS THE 8 SELECTIONS ARE + -- 10-3-12-5-14-7-8-9 (IN THIS ORDER + -- ).) + -- + -- + -- ( EACH DIVISION COMPRISES 3 FILES, + -- COVERING RESPECTIVELY THE FIRST + -- 3 , NEXT 2 , AND LAST 3 OF THE 8 + -- SELECTIONS FOR THE DIVISION.) + -- + -- + -- (1) ARRAY OBJECTS DECLARED IN THE SAME DECLARATION. + -- (TWO-DIMENSIONAL; NON-CONSTRAINABLE TYPEMARK.) + -- + -- (THIS WILL BE THE ONLY CASE INVOLVING OBJECTS DECLARED + -- IN THE SAME DECLARATION.) + -- + -- + -- (2) MULTIDIMENSIONAL ARRAY OBJECTS WHOSE TYPEMARKS WERE + -- DEFINED WITHOUT EVER USING THE "BOX" COMPOUND SYMBOL. + -- (TWO-DIMENSIONAL ARRAYS OF INTEGERS.) + -- + -- (SLICING IS ILLEGAL; SINCE IN THIS TEST WE ARE NEVER + -- USING AGGREGATES + -- (EXCEPT FOR ONE-DIMENSIONAL ARRAYS OF CHARACTERS; + -- SEE (5) ) + -- AND WE ARE NOT USING CONVERSION-TO-CONSTRAINED-TYPEMARKS + -- (AS IN T1(ARR) , WHERE ARR IS AN ARRAY + -- OBJECT AND T1 IS AN ARRAY TYPEMARK SIMILAR + -- -- AS MORE PRECISELY SPECIFIED IN RM 4.6(B) -- + -- TO THE TYPEMARK OF ARR ), + -- THE ARRAY ASSIGNMENT CANNOT INVOLVE ANY SLIDING, + -- AND THE TYPEMARKS ARE ESSENTIALLY THE SAME.) + -- + -- + -- (3) UNSLICED ONE-DIMENSIONAL ARRAY OBJECTS WHOSE TYPEMARKS + -- WERE DEFINED WITHOUT EVER USING THE "BOX" SYMBOL + -- AND FOR WHICH THE COMPONENT TYPE IS NOT 'CHARACTER' . + -- ((ONE-DIMENSIONAL) ARRAYS OF INTEGERS.) + -- + -- (SINCE WE ARE NOT USING AGGREGATES + -- AND WE ARE NOT USING CONVERSION-TO-CONSTRAINED-TYPEMARKS, + -- THE ARRAY ASSIGNMENT CANNOT INVOLVE ANY SLIDING, + -- AND THE TYPEMARKS ARE ESSENTIALLY THE SAME.) + -- + -- + -- (4) SLICED ONE-DIMENSIONAL ARRAY OBJECTS WHOSE TYPEMARKS + -- WERE DEFINED WITHOUT EVER USING THE "BOX" SYMBOL + -- AND FOR WHICH THE COMPONENT TYPE IS NOT 'CHARACTER' . + -- ((ONE-DIMENSIONAL) ARRAYS OF BOOLEANS.) + -- + -- (THE ASSIGNMENT MAY REQUIRE SLIDING.) + -- + -- (MOST SUBSEQUENT SUBCASES IN THIS TEST (OTHER THAN NULL + -- ASSIGNMENTS) WILL INVOLVE SLIDING; WE ASSUME THAT + -- SUBCASES WHICH WORK IN CONJUNCTION WITH SLIDING WORK + -- ALSO WHEN NO SLIDING IS INVOLVED.) + -- + -- + -- (5) UNSLICED ONE-DIMENSIONAL ARRAY OBJECTS WHOSE TYPEMARKS + -- WERE DEFINED WITHOUT EVER USING THE "BOX" SYMBOL + -- AND FOR WHICH THE COMPONENT TYPE IS 'CHARACTER' . + -- + -- (STRING LITERALS ARE THE ONLY AGGREGATES WE ARE USING + -- IN THIS TEST. TO FORCE SLIDING, THE LOWER LIMIT IMPLIED + -- BY THE TYPEMARK WILL NOT BE 1 .) + -- + -- + -- (6) SLICED ONE-DIMENSIONAL ARRAY OBJECTS WHOSE TYPEMARKS + -- WERE DEFINED WITHOUT EVER USING THE "BOX" SYMBOL + -- AND FOR WHICH THE COMPONENT TYPE IS 'CHARACTER' . + -- + -- + -- (7) UNSLICED OBJECTS OF THE PREDEFINED TYPE 'STRING' (BY + -- THEMSELVES). + -- + -- + -- (8) SLICED OBJECTS OF THE PREDEFINED TYPE 'STRING' , WITH + -- STRING LITERALS. + -- + -- + -- (9) SLICED OBJECTS OF THE PREDEFINED TYPE 'STRING' (BY + -- THEMSELVES). + -- + -- + -- (-) CONSTRAINABLE TYPES: ONLY SUBTESTS 2, 3, 4, 5, 6 + -- WILL BE REPLICATED -- AS SUBTESTS 10, 11, 12, 13, 14 . + -- + -- + -- (10) MULTIDIMENSIONAL ARRAY OBJECTS WHOSE TYPEMARKS WERE + -- DEFINED USING THE "BOX" COMPOUND SYMBOL. + -- (TWO-DIMENSIONAL ARRAYS OF INTEGERS.) + -- + -- + -- (11) UNSLICED ONE-DIMENSIONAL ARRAY OBJECTS WHOSE TYPEMARKS + -- WERE DEFINED USING THE "BOX" SYMBOL + -- AND FOR WHICH THE COMPONENT TYPE IS NOT 'CHARACTER' . + -- ((ONE-DIMENSIONAL) ARRAYS OF INTEGERS.) + -- + -- + -- (12) SLICED ONE-DIMENSIONAL ARRAY OBJECTS WHOSE TYPEMARKS + -- WERE DEFINED USING THE "BOX" SYMBOL + -- AND FOR WHICH THE COMPONENT TYPE IS NOT 'CHARACTER' . + -- ((ONE-DIMENSIONAL) ARRAYS OF BOOLEANS.) + -- + -- + -- (13) UNSLICED ONE-DIMENSIONAL ARRAY OBJECTS WHOSE TYPEMARKS + -- WERE DEFINED USING THE "BOX" SYMBOL + -- AND FOR WHICH THE COMPONENT TYPE IS 'CHARACTER' . + -- + -- (STRING LITERALS ARE THE ONLY AGGREGATES WE ARE USING + -- IN THIS TEST. TO FORCE SLIDING, THE LOWER LIMIT IMPLIED + -- BY THE TYPEMARK WILL NOT BE 1 .) + -- + -- + -- (14) SLICED ONE-DIMENSIONAL ARRAY OBJECTS WHOSE TYPEMARKS + -- WERE DEFINED USING THE "BOX" SYMBOL + -- AND FOR WHICH THE COMPONENT TYPE IS 'CHARACTER' . + -- + -- + -- + -- (-) SPECIAL CASES: SUPERLONG ARRAYS.. (TREATED FOR DYNAMIC + -- ARRAYS ONLY, + -- DIVISIONS C AND D .) + -- + -- + -- (-) THE DYNAMIC-ARRAY COUNTERPARTS OF THESE TESTS ARE IN DI- + -- VISIONS C (FOR NON-NULL ARRAYS) AND D (FOR NULL ARRAYS). + -- + -- + + + ------------------------------------------------------------------- + + -- (10) MULTIDIMENSIONAL ARRAY OBJECTS WHOSE TYPEMARKS WERE + -- DEFINED USING THE "BOX" COMPOUND SYMBOL. + -- (TWO-DIMENSIONAL ARRAYS OF INTEGERS.) + + DECLARE + + TYPE TABOX0 IS ARRAY( INTEGER RANGE <> , INTEGER RANGE <> + ) OF INTEGER ; + + SUBTYPE TABOX01 IS TABOX0( 1..0 , 0..7 ); + SUBTYPE TABOX02 IS TABOX0 ; + + ARRX01 : TABOX01 ; + ARRX02 : TABOX02( 7..6 , 20..27 ); + + BEGIN + + -- ARRAY ASSIGNMENT: + + ARRX02 := ARRX01 ; + + EXCEPTION + + WHEN OTHERS => + FAILED( "EXCEPTION RAISED - SUBTEST 10" ); + + END ; + + + ------------------------------------------------------------------- + + -- (3) UNSLICED ONE-DIMENSIONAL ARRAY OBJECTS WHOSE TYPEMARKS + -- WERE DEFINED WITHOUT EVER USING THE "BOX" SYMBOL + -- AND FOR WHICH THE COMPONENT TYPE IS NOT 'CHARACTER' . + -- ((ONE-DIMENSIONAL) ARRAYS OF INTEGERS.) + + DECLARE + + TYPE TA3 IS ARRAY( INTEGER RANGE 100..99 ) OF INTEGER ; + + SUBTYPE TA31 IS TA3 ; + SUBTYPE TA32 IS TA3 ; + + ARR31 : TA31 ; + ARR32 : TA32 ; + + BEGIN + + -- ARRAY ASSIGNMENT: + + ARR32 := ARR31 ; + + EXCEPTION + + WHEN OTHERS => + FAILED( "EXCEPTION RAISED - SUBTEST 3" ); + + END ; + + + ------------------------------------------------------------------- + + -- (12) SLICED ONE-DIMENSIONAL ARRAY OBJECTS WHOSE TYPEMARKS + -- WERE DEFINED USING THE "BOX" SYMBOL + -- AND FOR WHICH THE COMPONENT TYPE IS NOT 'CHARACTER' . + -- ((ONE-DIMENSIONAL) ARRAYS OF BOOLEANS.) + + DECLARE + + TYPE TABOX5 IS ARRAY( INTEGER RANGE <> ) OF BOOLEAN ; + + SUBTYPE TABOX51 IS TABOX5( 1..5 ); + + ARRX51 : TABOX51 ; + ARRX52 : TABOX5( 5..9 ); + + BEGIN + + -- INITIALIZATION OF RHS ARRAY: + + FOR I IN 1..5 LOOP + ARRX51( I ) := FALSE ; -- VALUES WILL BE: F T F F T + END LOOP; + + ARRX51(2) := TRUE ; + + ARRX51(5) := TRUE ; -- RHS VALUES ARE: F T F F T + + + -- INITIALIZATION OF LHS ARRAY: + + FOR I IN 5..9 LOOP + ARRX52( I ) := TRUE ; -- VALUES WILL BE: T F T T F + END LOOP; + + ARRX52(6) := FALSE ; + + ARRX52(9) := FALSE ; -- LHS VALUES ARE: T F T T F + + + -- NULL SLICE ASSIGNMENT: + + ARRX52(6..5) := ARRX51(4..3) ; + + + -- CHECKING THE VALUES AFTER THE SLICE ASSIGNMENT: + + IF ARRX52( 5 ) /= TRUE OR + ARRX52( 6 ) /= FALSE OR + ARRX52( 7 ) /= TRUE OR + ARRX52( 8 ) /= TRUE OR + ARRX52( 9 ) /= FALSE + THEN + FAILED( "SLICE ASSIGNMENT NOT CORRECT (VALUES)" ); + END IF; + + EXCEPTION + + WHEN OTHERS => + FAILED( "EXCEPTION RAISED - SUBTEST 12" ); + + END ; + + ------------------------------------------------------------------- + + + RESULT ; + + +END C52103F; diff --git a/gcc/testsuite/ada/acats/tests/c5/c52103g.ada b/gcc/testsuite/ada/acats/tests/c5/c52103g.ada new file mode 100644 index 000000000..0a3a8f15d --- /dev/null +++ b/gcc/testsuite/ada/acats/tests/c5/c52103g.ada @@ -0,0 +1,142 @@ +-- C52103G.ADA + +-- Grant of Unlimited Rights +-- +-- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687, +-- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained +-- unlimited rights in the software and documentation contained herein. +-- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making +-- this public release, the Government intends to confer upon all +-- recipients unlimited rights equal to those held by the Government. +-- These rights include rights to use, duplicate, release or disclose the +-- released technical data and computer software in whole or in part, in +-- any manner and for any purpose whatsoever, and to have or permit others +-- to do so. +-- +-- DISCLAIMER +-- +-- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR +-- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED +-- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF 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 LENGTHS MUST MATCH IN ARRAY AND SLICE ASSIGNMENTS. +-- MORE SPECIFICALLY, TEST THAT ARRAY ASSIGNMENTS WITH MATCHING +-- LENGTHS DO NOT CAUSE CONSTRAINT_ERROR TO BE RAISED AND +-- ARE PERFORMED CORRECTLY. +-- (OVERLAPS BETWEEN THE OPERANDS OF THE ASSIGNMENT STATEMENT +-- ARE TREATED ELSEWHERE.) + +-- THIS IS THE SECOND FILE IN +-- DIVISION B : STATICALLY-DETERMINABLE NULL LENGTHS. + + +-- RM 07/20/81 +-- SPS 3/22/83 + + +WITH REPORT; +PROCEDURE C52103G IS + + USE REPORT ; + +BEGIN + + TEST( "C52103G" , "CHECK THAT IN ARRAY ASSIGNMENTS AND IN SLICE" & + " ASSIGNMENTS THE LENGTHS MUST MATCH" ); + + + -- ( EACH DIVISION COMPRISES 3 FILES, + -- COVERING RESPECTIVELY THE FIRST + -- 3 , NEXT 2 , AND LAST 3 OF THE 8 + -- SELECTIONS FOR THE DIVISION.) + + + ------------------------------------------------------------------- + + -- (5) UNSLICED ONE-DIMENSIONAL ARRAY OBJECTS WHOSE TYPEMARKS + -- WERE DEFINED WITHOUT EVER USING THE "BOX" SYMBOL + -- AND FOR WHICH THE COMPONENT TYPE IS 'CHARACTER' . + -- + + DECLARE + + TYPE TA51 IS ARRAY( INTEGER RANGE 11..10 ) OF CHARACTER ; + + ARR51 : TA51 ; + + BEGIN + + + -- ARRAY ASSIGNMENT (WITH STRING AGGREGATE): + + ARR51 := "" ; + + + -- CHECKING THE VALUES AFTER THE ASSIGNMENT: + + IF ARR51 /= "" + THEN + FAILED( "ARRAY ASSIGNMENT NOT CORRECT (5)" ); + END IF; + + + EXCEPTION + + WHEN OTHERS => + FAILED( "EXCEPTION RAISED - SUBTEST 5" ); + + END ; + + + ------------------------------------------------------------------- + + -- (14) SLICED ONE-DIMENSIONAL ARRAY OBJECTS WHOSE TYPEMARKS + -- WERE DEFINED USING THE "BOX" SYMBOL + -- AND FOR WHICH THE COMPONENT TYPE IS 'CHARACTER' . + + DECLARE + + TYPE TABOX4 IS ARRAY( INTEGER RANGE <> ) OF CHARACTER ; + + SUBTYPE TABOX42 IS TABOX4( 11..15 ); + + ARRX42 : TABOX42 ; + + BEGIN + + -- INITIALIZATION OF LHS ARRAY: + + ARRX42 := "QUINC" ; + + + -- NULL SLICE ASSIGNMENT: + + ARRX42( 13..12 ) := "" ; + + + -- CHECKING THE VALUES AFTER THE SLICE ASSIGNMENT: + + IF ARRX42 /= "QUINC" OR + ARRX42( 11..15 ) /= "QUINC" + THEN + FAILED( "SLICE ASSIGNMENT NOT CORRECT (14)" ); + END IF; + + EXCEPTION + + WHEN OTHERS => + FAILED( "EXCEPTION RAISED - SUBTEST 14" ); + + END ; + + + ------------------------------------------------------------------- + + + RESULT ; + + +END C52103G; diff --git a/gcc/testsuite/ada/acats/tests/c5/c52103h.ada b/gcc/testsuite/ada/acats/tests/c5/c52103h.ada new file mode 100644 index 000000000..6915cb4cc --- /dev/null +++ b/gcc/testsuite/ada/acats/tests/c5/c52103h.ada @@ -0,0 +1,175 @@ +-- C52103H.ADA + +-- Grant of Unlimited Rights +-- +-- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687, +-- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained +-- unlimited rights in the software and documentation contained herein. +-- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making +-- this public release, the Government intends to confer upon all +-- recipients unlimited rights equal to those held by the Government. +-- These rights include rights to use, duplicate, release or disclose the +-- released technical data and computer software in whole or in part, in +-- any manner and for any purpose whatsoever, and to have or permit others +-- to do so. +-- +-- DISCLAIMER +-- +-- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR +-- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED +-- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF 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 LENGTHS MUST MATCH IN ARRAY AND SLICE ASSIGNMENTS. +-- MORE SPECIFICALLY, TEST THAT ARRAY ASSIGNMENTS WITH MATCHING +-- LENGTHS DO NOT CAUSE CONSTRAINT_ERROR TO BE RAISED AND +-- ARE PERFORMED CORRECTLY. +-- (OVERLAPS BETWEEN THE OPERANDS OF THE ASSIGNMENT STATEMENT +-- ARE TREATED ELSEWHERE.) + +-- THIS IS THE THIRD FILE IN +-- DIVISION B : STATICALLY-DETERMINABLE NULL LENGTHS. + + +-- RM 07/20/81 +-- SPS 3/22/83 + + +WITH REPORT; +PROCEDURE C52103H IS + + USE REPORT ; + +BEGIN + + TEST( "C52103H" , "CHECK THAT IN ARRAY ASSIGNMENTS AND IN SLICE" & + " ASSIGNMENTS THE LENGTHS MUST MATCH" ); + + + -- ( EACH DIVISION COMPRISES 3 FILES, + -- COVERING RESPECTIVELY THE FIRST + -- 3 , NEXT 2 , AND LAST 3 OF THE 8 + -- SELECTIONS FOR THE DIVISION.) + + + ------------------------------------------------------------------- + + -- (7) UNSLICED OBJECTS OF THE PREDEFINED TYPE 'STRING' (BY + -- THEMSELVES). + + DECLARE + + ARR71 : STRING( 1..0 ) := "" ; + ARR72 : STRING( 5..4 ) ; + + BEGIN + + + -- STRING ASSIGNMENT: + + ARR72 := ARR71 ; + + + -- CHECKING THE VALUES AFTER THE STRING ASSIGNMENT: + + IF ARR72 /= "" + THEN + FAILED( "STRING ASSIGNMENT NOT CORRECT (7)" ); + END IF; + + EXCEPTION + + WHEN OTHERS => + FAILED( "EXCEPTION RAISED - SUBTEST 7" ); + + END ; + + + ------------------------------------------------------------------- + + -- (8) SLICED OBJECTS OF THE PREDEFINED TYPE 'STRING' , WITH + -- STRING LITERALS. + -- + + DECLARE + + ARR82 : STRING( 5..9 ) ; + + BEGIN + + + -- INITIALIZATION OF LHS ARRAY: + + ARR82( 5..9 ) := "QUINC" ; + + + -- STRING LITERAL ASSIGNMENT: + + ARR82( 5..9 )( 6..9 )( 6..5 ) := "" ; + + + -- CHECKING THE VALUES AFTER THE SLICE ASSIGNMENT: + + IF ARR82 /= "QUINC" OR + ARR82( 5..9 ) /= "QUINC" + THEN + FAILED( "SLICE ASSIGNMENT NOT CORRECT (8)" ); + END IF; + + EXCEPTION + + WHEN OTHERS => + FAILED( "EXCEPTION RAISED - SUBTEST 8" ); + + END ; + + ------------------------------------------------------------------- + + -- (9) SLICED OBJECTS OF THE PREDEFINED TYPE 'STRING' (BY + -- THEMSELVES). + -- + + DECLARE + + SUBTYPE TA92 IS STRING( 5..9 ) ; + + ARR91 : STRING( 1..5 ) := "ABCDE" ; + ARR92 : TA92 ; + + BEGIN + + + -- INITIALIZATION OF LHS ARRAY: + + ARR92( 5..9 ) := "QUINC" ; + + + -- STRING SLICE ASSIGNMENT: + + ARR92( 5..9 )( 6..9 )( 8..7 ) := ARR91( 1..5 )( 5..4 ) ; + + + -- CHECKING THE VALUES AFTER THE SLICE ASSIGNMENT: + + IF ARR92 /= "QUINC" OR + ARR92( 5..9 ) /= "QUINC" + THEN + FAILED( "SLICE ASSIGNMENT NOT CORRECT (9)" ); + END IF; + + EXCEPTION + + WHEN OTHERS => + FAILED( "EXCEPTION RAISED - SUBTEST 9" ); + + END ; + + ------------------------------------------------------------------- + + + RESULT ; + + +END C52103H; diff --git a/gcc/testsuite/ada/acats/tests/c5/c52103k.ada b/gcc/testsuite/ada/acats/tests/c5/c52103k.ada new file mode 100644 index 000000000..f0d593be4 --- /dev/null +++ b/gcc/testsuite/ada/acats/tests/c5/c52103k.ada @@ -0,0 +1,393 @@ +-- C52103K.ADA + +-- Grant of Unlimited Rights +-- +-- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687, +-- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained +-- unlimited rights in the software and documentation contained herein. +-- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making +-- this public release, the Government intends to confer upon all +-- recipients unlimited rights equal to those held by the Government. +-- These rights include rights to use, duplicate, release or disclose the +-- released technical data and computer software in whole or in part, in +-- any manner and for any purpose whatsoever, and to have or permit others +-- to do so. +-- +-- DISCLAIMER +-- +-- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR +-- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED +-- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF 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 LENGTHS MUST MATCH IN ARRAY AND SLICE ASSIGNMENTS. +-- MORE SPECIFICALLY, TEST THAT ARRAY ASSIGNMENTS WITH MATCHING +-- LENGTHS DO NOT CAUSE CONSTRAINT_ERROR TO BE RAISED AND +-- ARE PERFORMED CORRECTLY. +-- (OVERLAPS BETWEEN THE OPERANDS OF THE ASSIGNMENT STATEMENT +-- ARE TREATED ELSEWHERE.) + +-- DIVISION C : NON-NULL ARRAYS WHOSE LENGTHS ARE NOT DETERMINABLE +-- STATICALLY. + + +-- RM 07/20/81 +-- SPS 3/22/83 + + +WITH REPORT; +PROCEDURE C52103K IS + + USE REPORT ; + +BEGIN + + TEST( "C52103K" , "CHECK THAT IN ARRAY ASSIGNMENTS AND IN SLICE" & + " ASSIGNMENTS THE LENGTHS MUST MATCH" ); + + + -- IN THIS TEST WE CAN'T USE AGGREGATE ASSIGNMENT (EXCEPT WHEN + -- THE AGGREGATES ARE STRING LITERALS); THEREFORE: + -- + -- (1) ARRAYS WILL BE INITIALIZED BY INDIVIDUAL ASSIGNMENTS; + -- (2) CAN'T USE NON-NULL CONSTANT ARRAYS. + + + -- WE ASSUME THAT IN AN ARRAY_TYPE_DEFINITION THE INDEX PORTION + -- AND THE COMPONENT_TYPE PORTION ARE FUNCTIONALLY ORTHOGONAL + -- ALSO AT THE IMPLEMENTATION LEVEL, I.E. THAT THE CORRECTNESS + -- OF THE ACCESSING MECHANISM FOR ARRAYS DOES NOT DEPEND ON + -- COMPONENT_TYPE. ACCORDINGLY WE ARE TESTING FOR SOME BUT + -- NOT ALL KINDS OF COMPONENT_TYPE. (COMPONENT_TYPES INCLUDED: + -- INTEGER , CHARACTER , BOOLEAN .) + + + -- CASES DISTINGUISHED: ( 8 SELECTED CASES ARE IMPLEMENTED) + -- + -- ( THE SELECTIONS ARE 7 , 8 , 9 , + -- AND PRECISELY 5 CASES FROM THE + -- TWO 5-CASE SERIES 2-3-4-5-6 AND + -- 10-11-12-13-14) + -- + -- ( IN THE CURRENT DIVISION, THE 5 + -- FLOATING SELECTIONS ARE 2-11-4- + -- -13-6 ; THUS THE 8 SELECTIONS ARE + -- 2-11-4-13-6-7-8-9 (IN THIS ORDER) + -- .) + -- + -- + -- ( EACH DIVISION COMPRISES 3 FILES, + -- COVERING RESPECTIVELY THE FIRST + -- 3 , NEXT 2 , AND LAST 3 OF THE 8 + -- SELECTIONS FOR THE DIVISION.) + -- + -- + -- (1) ARRAY OBJECTS DECLARED IN THE SAME DECLARATION. + -- (TWO-DIMENSIONAL; NON-CONSTRAINABLE TYPEMARK.) + -- + -- (THIS WILL BE THE ONLY CASE INVOLVING OBJECTS DECLARED + -- IN THE SAME DECLARATION.) + -- + -- + -- (2) MULTIDIMENSIONAL ARRAY OBJECTS WHOSE TYPEMARKS WERE + -- DEFINED WITHOUT EVER USING THE "BOX" COMPOUND SYMBOL. + -- (TWO-DIMENSIONAL ARRAYS OF INTEGERS.) + -- + -- (SLICING IS ILLEGAL; SINCE IN THIS TEST WE ARE NEVER + -- USING AGGREGATES + -- (EXCEPT FOR ONE-DIMENSIONAL ARRAYS OF CHARACTERS; + -- SEE (5) ) + -- AND WE ARE NOT USING CONVERSION-TO-CONSTRAINED-TYPEMARKS + -- (AS IN T1(ARR) , WHERE ARR IS AN ARRAY + -- OBJECT AND T1 IS AN ARRAY TYPEMARK SIMILAR + -- -- AS MORE PRECISELY SPECIFIED IN RM 4.6(B) -- + -- TO THE TYPEMARK OF ARR ), + -- THE ARRAY ASSIGNMENT CANNOT INVOLVE ANY SLIDING, + -- AND THE TYPEMARKS ARE ESSENTIALLY THE SAME.) + -- + -- + -- (3) UNSLICED ONE-DIMENSIONAL ARRAY OBJECTS WHOSE TYPEMARKS + -- WERE DEFINED WITHOUT EVER USING THE "BOX" SYMBOL + -- AND FOR WHICH THE COMPONENT TYPE IS NOT 'CHARACTER' . + -- ((ONE-DIMENSIONAL) ARRAYS OF INTEGERS.) + -- + -- (SINCE WE ARE NOT USING AGGREGATES + -- AND WE ARE NOT USING CONVERSION-TO-CONSTRAINED-TYPEMARKS, + -- THE ARRAY ASSIGNMENT CANNOT INVOLVE ANY SLIDING, + -- AND THE TYPEMARKS ARE ESSENTIALLY THE SAME.) + -- + -- + -- (4) SLICED ONE-DIMENSIONAL ARRAY OBJECTS WHOSE TYPEMARKS + -- WERE DEFINED WITHOUT EVER USING THE "BOX" SYMBOL + -- AND FOR WHICH THE COMPONENT TYPE IS NOT 'CHARACTER' . + -- ((ONE-DIMENSIONAL) ARRAYS OF INTEGERS.) + -- + -- (THE ASSIGNMENT MAY REQUIRE SLIDING.) + -- + -- (MOST SUBSEQUENT SUBCASES IN THIS TEST (OTHER THAN NULL + -- ASSIGNMENTS) WILL INVOLVE SLIDING; WE ASSUME THAT + -- SUBCASES WHICH WORK IN CONJUNCTION WITH SLIDING WORK + -- ALSO WHEN NO SLIDING IS INVOLVED.) + -- + -- + -- (5) UNSLICED ONE-DIMENSIONAL ARRAY OBJECTS WHOSE TYPEMARKS + -- WERE DEFINED WITHOUT EVER USING THE "BOX" SYMBOL + -- AND FOR WHICH THE COMPONENT TYPE IS 'CHARACTER' . + -- + -- (STRING LITERALS ARE THE ONLY AGGREGATES WE ARE USING + -- IN THIS TEST. TO FORCE SLIDING, THE LOWER LIMIT IMPLIED + -- BY THE TYPEMARK WILL NOT BE 1 .) + -- + -- + -- (6) SLICED ONE-DIMENSIONAL ARRAY OBJECTS WHOSE TYPEMARKS + -- WERE DEFINED WITHOUT EVER USING THE "BOX" SYMBOL + -- AND FOR WHICH THE COMPONENT TYPE IS 'CHARACTER' . + -- + -- + -- (7) UNSLICED OBJECTS OF THE PREDEFINED TYPE 'STRING' (BY + -- THEMSELVES). + -- + -- + -- (8) SLICED OBJECTS OF THE PREDEFINED TYPE 'STRING' , WITH + -- STRING LITERALS. + -- + -- + -- (9) SLICED OBJECTS OF THE PREDEFINED TYPE 'STRING' (BY + -- THEMSELVES). + -- + -- + -- (-) CONSTRAINABLE TYPES: ONLY SUBTESTS 2, 3, 4, 5, 6 + -- WILL BE REPLICATED -- AS SUBTESTS 10, 11, 12, 13, 14 . + -- + -- + -- (10) MULTIDIMENSIONAL ARRAY OBJECTS WHOSE TYPEMARKS WERE + -- DEFINED USING THE "BOX" COMPOUND SYMBOL. + -- (TWO-DIMENSIONAL ARRAYS OF INTEGERS.) + -- + -- + -- (11) UNSLICED ONE-DIMENSIONAL ARRAY OBJECTS WHOSE TYPEMARKS + -- WERE DEFINED USING THE "BOX" SYMBOL + -- AND FOR WHICH THE COMPONENT TYPE IS NOT 'CHARACTER' . + -- ((ONE-DIMENSIONAL) ARRAYS OF INTEGERS.) + -- + -- + -- (12) SLICED ONE-DIMENSIONAL ARRAY OBJECTS WHOSE TYPEMARKS + -- WERE DEFINED USING THE "BOX" SYMBOL + -- AND FOR WHICH THE COMPONENT TYPE IS NOT 'CHARACTER' . + -- ((ONE-DIMENSIONAL) ARRAYS OF BOOLEANS.) + -- + -- + -- (13) UNSLICED ONE-DIMENSIONAL ARRAY OBJECTS WHOSE TYPEMARKS + -- WERE DEFINED USING THE "BOX" SYMBOL + -- AND FOR WHICH THE COMPONENT TYPE IS 'CHARACTER' . + -- + -- (STRING LITERALS ARE THE ONLY AGGREGATES WE ARE USING + -- IN THIS TEST. TO FORCE SLIDING, THE LOWER LIMIT IMPLIED + -- BY THE TYPEMARK WILL NOT BE 1 .) + -- + -- + -- (14) SLICED ONE-DIMENSIONAL ARRAY OBJECTS WHOSE TYPEMARKS + -- WERE DEFINED USING THE "BOX" SYMBOL + -- AND FOR WHICH THE COMPONENT TYPE IS 'CHARACTER' . + -- + -- + -- + -- (-) SPECIAL CASES: NULL ARRAYS....... TREATED IN DIVISION B. + -- SUPERLONG ARRAYS.. (TREATED FOR DYNAMIC + -- ARRAYS ONLY, + -- DIVISIONS C AND D .) + -- + -- + -- (-) THE DYNAMIC-ARRAY COUNTERPARTS OF THESE TESTS ARE IN DI- + -- VISIONS C (FOR NON-NULL ARRAYS) AND D (FOR NULL ARRAYS). + -- + -- + + + ------------------------------------------------------------------- + + -- (2) MULTIDIMENSIONAL ARRAY OBJECTS WHOSE TYPEMARKS WERE + -- DEFINED WITHOUT EVER USING THE "BOX" COMPOUND SYMBOL. + -- (TWO-DIMENSIONAL ARRAYS OF INTEGERS.) + + DECLARE + + TYPE TA21 IS ARRAY( + INTEGER RANGE IDENT_INT(1)..IDENT_INT(5) , + INTEGER RANGE IDENT_INT(0)..IDENT_INT(7) + ) OF INTEGER ; + + SUBTYPE TA22 IS TA21 ; + + ARR21 : TA21 ; + ARR22 : TA22 ; + + BEGIN + + -- INITIALIZATION OF RHS ARRAY: + + FOR I IN IDENT_INT(1)..IDENT_INT(5) LOOP + + FOR J IN IDENT_INT(0)..IDENT_INT(7) LOOP + ARR21( I , J ) := I * I * J ; + END LOOP; + + END LOOP; + + + -- ARRAY ASSIGNMENT: + + ARR22 := ARR21 ; + + -- CHECKING THE VALUES AFTER THE ARRAY ASSIGNMENT: + + FOR I IN IDENT_INT(1)..IDENT_INT(5) LOOP + + FOR J IN IDENT_INT(0)..IDENT_INT(7) LOOP + + IF ARR22( I , J ) /= ( I-0 ) * ( I-0 ) * ( J-0 ) + THEN + FAILED( "ARRAY ASSIGNMENT NOT CORRECT" ); + END IF; + + END LOOP; + + END LOOP; + + + EXCEPTION + + WHEN OTHERS => + FAILED( "EXCEPTION RAISED - SUBTEST 2" ); + + END ; + + + ------------------------------------------------------------------- + + -- (11) UNSLICED ONE-DIMENSIONAL ARRAY OBJECTS WHOSE TYPEMARKS + -- WERE DEFINED USING THE "BOX" SYMBOL + -- AND FOR WHICH THE COMPONENT TYPE IS NOT 'CHARACTER' . + -- ((ONE-DIMENSIONAL) ARRAYS OF INTEGERS.) + + DECLARE + + TYPE TABOX1 IS ARRAY( INTEGER RANGE <> ) OF INTEGER ; + + SUBTYPE TABOX11 IS TABOX1( IDENT_INT(1)..IDENT_INT(5) ) ; + + ARRX11 : TABOX11 ; + ARRX12 : TABOX1( IDENT_INT(5)..IDENT_INT(9) ); + + BEGIN + + -- INITIALIZATION OF RHS ARRAY: + + FOR I IN IDENT_INT(1)..IDENT_INT(5) LOOP + ARRX11( I ) := I * I ; + END LOOP; + + + -- ARRAY ASSIGNMENT: + + ARRX12 := ARRX11 ; + + -- CHECKING THE VALUES AFTER THE ARRAY ASSIGNMENT: + + FOR I IN IDENT_INT(5)..IDENT_INT(9) LOOP + + IF ARRX12( I ) /= ( I-4 ) * ( I-4 ) + THEN + FAILED( "ARRAY ASSIGNMENT NOT CORRECT (11)" ); + END IF; + + END LOOP; + + + EXCEPTION + + WHEN OTHERS => + FAILED( "EXCEPTION RAISED - SUBTEST 11" ); + + END ; + + + ------------------------------------------------------------------- + + -- (4) SLICED ONE-DIMENSIONAL ARRAY OBJECTS WHOSE TYPEMARKS + -- WERE DEFINED WITHOUT EVER USING THE "BOX" SYMBOL + -- AND FOR WHICH THE COMPONENT TYPE IS NOT 'CHARACTER' . + -- ((ONE-DIMENSIONAL) ARRAYS OF BOOLEANS.) + + DECLARE + + TYPE TA42 IS ARRAY( + INTEGER RANGE IDENT_INT(1)..IDENT_INT(5) + ) OF BOOLEAN ; + + SUBTYPE TA41 IS TA42 ; + + ARR41 : TA41 ; + ARR42 : TA42 ; + + BEGIN + + -- INITIALIZATION OF RHS ARRAY: + + FOR I IN IDENT_INT(1)..IDENT_INT(5) LOOP + ARR41( I ) := FALSE ; -- VALUES WILL BE: F T F F T + END LOOP; + + ARR41(2) := TRUE ; + + ARR41(5) := TRUE ; -- RHS VALUES ARE: F T F F T + + + -- INITIALIZATION OF UNUSED COMPONENT OF LHS ARRAY: + + ARR42( 1 ) := TRUE ; + + + -- SLICE ASSIGNMENT: + + ARR42( IDENT_INT(2)..IDENT_INT(5) ) := + ARR41( + IDENT_INT(1)..IDENT_INT(4) ) ; + + + -- CHECKING THE VALUES AFTER THE SLICE ASSIGNMENT: + + FOR I IN IDENT_INT(2)..IDENT_INT(5) LOOP + + IF ARR42( I ) /= FALSE AND I /= 3 + THEN + FAILED( "SLICE ASSIGNMENT NOT CORRECT (VALUES)" ); + ELSIF ARR42( I ) /= TRUE AND I = 3 + THEN + FAILED( "SLICE ASSIGNMENT NOT CORRECT (VALUES)" ); + END IF; + + END LOOP; + + IF ARR42( 1 ) /= TRUE + THEN + FAILED( "SLICE ASSIGNMENT NOT CORRECT (SLIDING)" ); + END IF; + + EXCEPTION + + WHEN OTHERS => + FAILED( "EXCEPTION RAISED - SUBTEST 4" ); + + END ; + + + ------------------------------------------------------------------- + + + RESULT ; + + +END C52103K; diff --git a/gcc/testsuite/ada/acats/tests/c5/c52103l.ada b/gcc/testsuite/ada/acats/tests/c5/c52103l.ada new file mode 100644 index 000000000..528745ce2 --- /dev/null +++ b/gcc/testsuite/ada/acats/tests/c5/c52103l.ada @@ -0,0 +1,145 @@ +-- C52103L.ADA + +-- Grant of Unlimited Rights +-- +-- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687, +-- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained +-- unlimited rights in the software and documentation contained herein. +-- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making +-- this public release, the Government intends to confer upon all +-- recipients unlimited rights equal to those held by the Government. +-- These rights include rights to use, duplicate, release or disclose the +-- released technical data and computer software in whole or in part, in +-- any manner and for any purpose whatsoever, and to have or permit others +-- to do so. +-- +-- DISCLAIMER +-- +-- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR +-- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED +-- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF 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 LENGTHS MUST MATCH IN ARRAY AND SLICE ASSIGNMENTS. +-- MORE SPECIFICALLY, TEST THAT ARRAY ASSIGNMENTS WITH MATCHING +-- LENGTHS DO NOT CAUSE CONSTRAINT_ERROR TO BE RAISED AND +-- ARE PERFORMED CORRECTLY. +-- (OVERLAPS BETWEEN THE OPERANDS OF THE ASSIGNMENT STATEMENT +-- ARE TREATED ELSEWHERE.) + +-- THIS IS THE SECOND FILE IN +-- DIVISION C : NON-NULL ARRAYS WHOSE LENGTHS ARE NOT DETERMINABLE +-- STATICALLY. + + + +-- RM 07/20/81 +-- SPS 3/22/83 + + +WITH REPORT; +PROCEDURE C52103L IS + + USE REPORT ; + +BEGIN + + TEST( "C52103L" , "CHECK THAT IN ARRAY ASSIGNMENTS AND IN SLICE" & + " ASSIGNMENTS THE LENGTHS MUST MATCH" ); + + + -- ( EACH DIVISION COMPRISES 3 FILES, + -- COVERING RESPECTIVELY THE FIRST + -- 3 , NEXT 2 , AND LAST 3 OF THE 8 + -- SELECTIONS FOR THE DIVISION.) + + + ------------------------------------------------------------------- + + -- (13) UNSLICED ONE-DIMENSIONAL ARRAY OBJECTS WHOSE TYPEMARKS + -- WERE DEFINED USING THE "BOX" SYMBOL + -- AND FOR WHICH THE COMPONENT TYPE IS 'CHARACTER' . + + DECLARE + + TYPE TABOX3 IS ARRAY( INTEGER RANGE <> ) OF CHARACTER ; + + ARRX31 : TABOX3( IDENT_INT(11)..IDENT_INT(15) ); + + BEGIN + + + -- ARRAY ASSIGNMENT (WITH STRING AGGREGATE): + + ARRX31 := "QUINC" ; -- "QUINC"(1..5) SLIDES TO 11..15 + + + -- CHECKING THE VALUES AFTER THE ASSIGNMENT: + + IF ARRX31 /= "QUINC" OR + ARRX31( IDENT_INT(11)..IDENT_INT(15) ) /= "QUINC" + THEN + FAILED( "ARRAY ASSIGNMENT NOT CORRECT (13)" ); + END IF; + + EXCEPTION + + WHEN OTHERS => + FAILED( "EXCEPTION RAISED - SUBTEST 13" ); + + END ; + + + ------------------------------------------------------------------- + + -- (6) SLICED ONE-DIMENSIONAL ARRAY OBJECTS WHOSE TYPEMARKS + -- WERE DEFINED WITHOUT EVER USING THE "BOX" SYMBOL + -- AND FOR WHICH THE COMPONENT TYPE IS 'CHARACTER' . + -- + + DECLARE + + TYPE TA61 IS ARRAY( + INTEGER RANGE IDENT_INT(11)..IDENT_INT(15) + ) OF CHARACTER ; + + ARR61 : TA61 ; + + BEGIN + + -- INITIALIZATION OF UNUSED COMPONENT OF LHS ARRAY: + + ARR61( IDENT_INT(11)..IDENT_INT(11) ) := "Q" ; + + + -- SLICE ASSIGNMENT: + + ARR61( IDENT_INT(12)..IDENT_INT(15) ) := "UINC" ; + -- "UINC"(1..4) SLIDES TO 12..15 + + + -- CHECKING THE VALUES AFTER THE SLICE ASSIGNMENT: + + IF ARR61 /= "QUINC" OR + ARR61( IDENT_INT(11)..IDENT_INT(15) ) /= "QUINC" + THEN + FAILED( "SLICE ASSIGNMENT NOT CORRECT (6)" ); + END IF; + + EXCEPTION + + WHEN OTHERS => + FAILED( "EXCEPTION RAISED - SUBTEST 6" ); + + END ; + + + ------------------------------------------------------------------- + + + RESULT ; + + +END C52103L ; diff --git a/gcc/testsuite/ada/acats/tests/c5/c52103m.ada b/gcc/testsuite/ada/acats/tests/c5/c52103m.ada new file mode 100644 index 000000000..2377248b8 --- /dev/null +++ b/gcc/testsuite/ada/acats/tests/c5/c52103m.ada @@ -0,0 +1,183 @@ +-- C52103M.ADA + +-- Grant of Unlimited Rights +-- +-- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687, +-- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained +-- unlimited rights in the software and documentation contained herein. +-- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making +-- this public release, the Government intends to confer upon all +-- recipients unlimited rights equal to those held by the Government. +-- These rights include rights to use, duplicate, release or disclose the +-- released technical data and computer software in whole or in part, in +-- any manner and for any purpose whatsoever, and to have or permit others +-- to do so. +-- +-- DISCLAIMER +-- +-- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR +-- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED +-- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF 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 LENGTHS MUST MATCH IN ARRAY AND SLICE ASSIGNMENTS. +-- MORE SPECIFICALLY, TEST THAT ARRAY ASSIGNMENTS WITH MATCHING +-- LENGTHS DO NOT CAUSE CONSTRAINT_ERROR TO BE RAISED AND +-- ARE PERFORMED CORRECTLY. +-- (OVERLAPS BETWEEN THE OPERANDS OF THE ASSIGNMENT STATEMENT +-- ARE TREATED ELSEWHERE.) + +-- THIS IS THE THIRD FILE IN +-- DIVISION C : NON-NULL ARRAYS WHOSE LENGTHS ARE NOT DETERMINABLE +-- STATICALLY. + + +-- RM 07/20/81 +-- SPS 3/22/83 + + +WITH REPORT; +PROCEDURE C52103M IS + + USE REPORT ; + +BEGIN + + TEST( "C52103M" , "CHECK THAT IN ARRAY ASSIGNMENTS AND IN SLICE" & + " ASSIGNMENTS THE LENGTHS MUST MATCH" ); + + + -- ( EACH DIVISION COMPRISES 3 FILES, + -- COVERING RESPECTIVELY THE FIRST + -- 3 , NEXT 2 , AND LAST 3 OF THE 8 + -- SELECTIONS FOR THE DIVISION.) + + + ------------------------------------------------------------------- + + -- (7) UNSLICED OBJECTS OF THE PREDEFINED TYPE 'STRING' (BY + -- THEMSELVES). + + DECLARE + + ARR71 : STRING( IDENT_INT(1)..IDENT_INT(5) ) := "ABCDE" ; + ARR72 : STRING( IDENT_INT(5)..IDENT_INT(9) ) := "FGHIJ" ; + + BEGIN + + + -- STRING ASSIGNMENT: + + ARR72 := ARR71 ; + + + -- CHECKING THE VALUES AFTER THE STRING ASSIGNMENT: + + IF ARR72 /= "ABCDE" + THEN + FAILED( "STRING ASSIGNMENT NOT CORRECT (7)" ); + END IF; + + EXCEPTION + + WHEN OTHERS => + FAILED( "EXCEPTION RAISED - SUBTEST 7" ); + + END ; + + + ------------------------------------------------------------------- + + -- (8) SLICED OBJECTS OF THE PREDEFINED TYPE 'STRING' , WITH + -- STRING LITERALS. + -- + + DECLARE + + ARR82 : STRING( IDENT_INT(5)..IDENT_INT(9) ) ; + + BEGIN + + + -- INITIALIZATION OF UNUSED COMPONENT OF LHS ARRAY: + + ARR82( IDENT_INT(5)..IDENT_INT(5) ) := "Q" ; + + + -- STRING LITERAL ASSIGNMENT: + + ARR82( IDENT_INT(5)..IDENT_INT(9) ) + ( IDENT_INT(6)..IDENT_INT(9) ) := "BCDE" ; + + + -- CHECKING THE VALUES AFTER THE SLICE ASSIGNMENT: + + IF ARR82 /= "QBCDE" OR + ARR82( IDENT_INT(5)..IDENT_INT(9) ) /= "QBCDE" + THEN + FAILED( "SLICE ASSIGNMENT NOT CORRECT (8)" ); + END IF; + + EXCEPTION + + WHEN OTHERS => + FAILED( "EXCEPTION RAISED - SUBTEST 8" ); + + END ; + + ------------------------------------------------------------------- + + -- (9) SLICED OBJECTS OF THE PREDEFINED TYPE 'STRING' (BY + -- THEMSELVES). + -- + + DECLARE + + SUBTYPE TA92 IS STRING( IDENT_INT(5)..IDENT_INT(9) ) ; + + ARR91 : STRING( IDENT_INT(1)..IDENT_INT(5) ) := "ABCDE" ; + ARR92 : TA92 ; + + BEGIN + + + -- INITIALIZATION OF UNUSED COMPONENT OF LHS ARRAY: + + ARR92( IDENT_INT(5)..IDENT_INT(5) ) := "Q" ; + + + -- STRING SLICE ASSIGNMENT: + + ARR92( IDENT_INT(5)..IDENT_INT(9) ) + ( IDENT_INT(6)..IDENT_INT(9) ) := + ARR91 + ( IDENT_INT(1)..IDENT_INT(5) ) + ( IDENT_INT(2)..IDENT_INT(5) ) + ( IDENT_INT(2)..IDENT_INT(5) ) ; + + + -- CHECKING THE VALUES AFTER THE SLICE ASSIGNMENT: + + IF ARR92 /= "QBCDE" OR + ARR92( IDENT_INT(5)..IDENT_INT(9) ) /= "QBCDE" + THEN + FAILED( "SLICE ASSIGNMENT NOT CORRECT (9)" ); + END IF; + + EXCEPTION + + WHEN OTHERS => + FAILED( "EXCEPTION RAISED - SUBTEST 9" ); + + END ; + + + ------------------------------------------------------------------- + + + RESULT ; + + +END C52103M ; diff --git a/gcc/testsuite/ada/acats/tests/c5/c52103p.ada b/gcc/testsuite/ada/acats/tests/c5/c52103p.ada new file mode 100644 index 000000000..7cbd7a589 --- /dev/null +++ b/gcc/testsuite/ada/acats/tests/c5/c52103p.ada @@ -0,0 +1,344 @@ +-- C52103P.ADA + +-- Grant of Unlimited Rights +-- +-- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687, +-- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained +-- unlimited rights in the software and documentation contained herein. +-- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making +-- this public release, the Government intends to confer upon all +-- recipients unlimited rights equal to those held by the Government. +-- These rights include rights to use, duplicate, release or disclose the +-- released technical data and computer software in whole or in part, in +-- any manner and for any purpose whatsoever, and to have or permit others +-- to do so. +-- +-- DISCLAIMER +-- +-- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR +-- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED +-- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF 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 LENGTHS MUST MATCH IN ARRAY AND SLICE ASSIGNMENTS. +-- MORE SPECIFICALLY, TEST THAT ARRAY ASSIGNMENTS WITH MATCHING +-- LENGTHS DO NOT CAUSE CONSTRAINT_ERROR TO BE RAISED AND +-- ARE PERFORMED CORRECTLY. +-- (OVERLAPS BETWEEN THE OPERANDS OF THE ASSIGNMENT STATEMENT +-- ARE TREATED ELSEWHERE.) + +-- DIVISION D : NULL LENGTHS NOT DETERMINABLE STATICALLY. + + +-- RM 07/20/81 +-- SPS 3/22/83 + + +WITH REPORT; +PROCEDURE C52103P IS + + USE REPORT ; + +BEGIN + + TEST( "C52103P" , "CHECK THAT IN ARRAY ASSIGNMENTS AND IN SLICE" & + " ASSIGNMENTS THE LENGTHS MUST MATCH" ); + + + -- IN THIS TEST WE CAN'T USE AGGREGATE ASSIGNMENT (EXCEPT WHEN + -- THE AGGREGATES ARE STRING LITERALS); THEREFORE: + -- + -- (1) ARRAYS WILL BE INITIALIZED BY INDIVIDUAL ASSIGNMENTS; + -- (2) CAN'T USE NON-NULL CONSTANT ARRAYS. + + + -- WE ASSUME THAT IN AN ARRAY_TYPE_DEFINITION THE INDEX PORTION + -- AND THE COMPONENT_TYPE PORTION ARE FUNCTIONALLY ORTHOGONAL + -- ALSO AT THE IMPLEMENTATION LEVEL, I.E. THAT THE CORRECTNESS + -- OF THE ACCESSING MECHANISM FOR ARRAYS DOES NOT DEPEND ON + -- COMPONENT_TYPE. ACCORDINGLY WE ARE TESTING FOR SOME BUT + -- NOT ALL KINDS OF COMPONENT_TYPE. (COMPONENT_TYPES INCLUDED: + -- INTEGER , CHARACTER , BOOLEAN .) + + + -- CASES DISTINGUISHED: ( 8 SELECTED CASES ARE IMPLEMENTED) + -- + -- ( THE SELECTIONS ARE 7 , 8 , 9 , + -- AND PRECISELY 5 CASES FROM THE + -- TWO 5-CASE SERIES 2-3-4-5-6 AND + -- 10-11-12-13-14) + -- + -- ( IN THE CURRENT DIVISION, THE 5 + -- FLOATING SELECTIONS ARE 10-3-12- + -- -5-14 ; THUS THE 8 SELECTIONS ARE + -- 10-3-12-5-14-7-8-9 (IN THIS ORDER + -- ).) + -- + -- + -- ( EACH DIVISION COMPRISES 3 FILES, + -- COVERING RESPECTIVELY THE FIRST + -- 3 , NEXT 2 , AND LAST 3 OF THE 8 + -- SELECTIONS FOR THE DIVISION.) + -- + -- + -- (1) ARRAY OBJECTS DECLARED IN THE SAME DECLARATION. + -- (TWO-DIMENSIONAL; NON-CONSTRAINABLE TYPEMARK.) + -- + -- (THIS WILL BE THE ONLY CASE INVOLVING OBJECTS DECLARED + -- IN THE SAME DECLARATION.) + -- + -- + -- (2) MULTIDIMENSIONAL ARRAY OBJECTS WHOSE TYPEMARKS WERE + -- DEFINED WITHOUT EVER USING THE "BOX" COMPOUND SYMBOL. + -- (TWO-DIMENSIONAL ARRAYS OF INTEGERS.) + -- + -- (SLICING IS ILLEGAL; SINCE IN THIS TEST WE ARE NEVER + -- USING AGGREGATES + -- (EXCEPT FOR ONE-DIMENSIONAL ARRAYS OF CHARACTERS; + -- SEE (5) ) + -- AND WE ARE NOT USING CONVERSION-TO-CONSTRAINED-TYPEMARKS + -- (AS IN T1(ARR) , WHERE ARR IS AN ARRAY + -- OBJECT AND T1 IS AN ARRAY TYPEMARK SIMILAR + -- -- AS MORE PRECISELY SPECIFIED IN RM 4.6(B) -- + -- TO THE TYPEMARK OF ARR ), + -- THE ARRAY ASSIGNMENT CANNOT INVOLVE ANY SLIDING, + -- AND THE TYPEMARKS ARE ESSENTIALLY THE SAME.) + -- + -- + -- (3) UNSLICED ONE-DIMENSIONAL ARRAY OBJECTS WHOSE TYPEMARKS + -- WERE DEFINED WITHOUT EVER USING THE "BOX" SYMBOL + -- AND FOR WHICH THE COMPONENT TYPE IS NOT 'CHARACTER' . + -- ((ONE-DIMENSIONAL) ARRAYS OF INTEGERS.) + -- + -- (SINCE WE ARE NOT USING AGGREGATES + -- AND WE ARE NOT USING CONVERSION-TO-CONSTRAINED-TYPEMARKS, + -- THE ARRAY ASSIGNMENT CANNOT INVOLVE ANY SLIDING, + -- AND THE TYPEMARKS ARE ESSENTIALLY THE SAME.) + -- + -- + -- (4) SLICED ONE-DIMENSIONAL ARRAY OBJECTS WHOSE TYPEMARKS + -- WERE DEFINED WITHOUT EVER USING THE "BOX" SYMBOL + -- AND FOR WHICH THE COMPONENT TYPE IS NOT 'CHARACTER' . + -- ((ONE-DIMENSIONAL) ARRAYS OF BOOLEANS.) + -- + -- (THE ASSIGNMENT MAY REQUIRE SLIDING.) + -- + -- (MOST SUBSEQUENT SUBCASES IN THIS TEST (OTHER THAN NULL + -- ASSIGNMENTS) WILL INVOLVE SLIDING; WE ASSUME THAT + -- SUBCASES WHICH WORK IN CONJUNCTION WITH SLIDING WORK + -- ALSO WHEN NO SLIDING IS INVOLVED.) + -- + -- + -- (5) UNSLICED ONE-DIMENSIONAL ARRAY OBJECTS WHOSE TYPEMARKS + -- WERE DEFINED WITHOUT EVER USING THE "BOX" SYMBOL + -- AND FOR WHICH THE COMPONENT TYPE IS 'CHARACTER' . + -- + -- (STRING LITERALS ARE THE ONLY AGGREGATES WE ARE USING + -- IN THIS TEST. TO FORCE SLIDING, THE LOWER LIMIT IMPLIED + -- BY THE TYPEMARK WILL NOT BE 1 .) + -- + -- + -- (6) SLICED ONE-DIMENSIONAL ARRAY OBJECTS WHOSE TYPEMARKS + -- WERE DEFINED WITHOUT EVER USING THE "BOX" SYMBOL + -- AND FOR WHICH THE COMPONENT TYPE IS 'CHARACTER' . + -- + -- + -- (7) UNSLICED OBJECTS OF THE PREDEFINED TYPE 'STRING' (BY + -- THEMSELVES). + -- + -- + -- (8) SLICED OBJECTS OF THE PREDEFINED TYPE 'STRING' , WITH + -- STRING LITERALS. + -- + -- + -- (9) SLICED OBJECTS OF THE PREDEFINED TYPE 'STRING' (BY + -- THEMSELVES). + -- + -- + -- (-) CONSTRAINABLE TYPES: ONLY SUBTESTS 2, 3, 4, 5, 6 + -- WILL BE REPLICATED -- AS SUBTESTS 10, 11, 12, 13, 14 . + -- + -- + -- (10) MULTIDIMENSIONAL ARRAY OBJECTS WHOSE TYPEMARKS WERE + -- DEFINED USING THE "BOX" COMPOUND SYMBOL. + -- (TWO-DIMENSIONAL ARRAYS OF INTEGERS.) + -- + -- + -- (11) UNSLICED ONE-DIMENSIONAL ARRAY OBJECTS WHOSE TYPEMARKS + -- WERE DEFINED USING THE "BOX" SYMBOL + -- AND FOR WHICH THE COMPONENT TYPE IS NOT 'CHARACTER' . + -- ((ONE-DIMENSIONAL) ARRAYS OF INTEGERS.) + -- + -- + -- (12) SLICED ONE-DIMENSIONAL ARRAY OBJECTS WHOSE TYPEMARKS + -- WERE DEFINED USING THE "BOX" SYMBOL + -- AND FOR WHICH THE COMPONENT TYPE IS NOT 'CHARACTER' . + -- ((ONE-DIMENSIONAL) ARRAYS OF BOOLEANS.) + -- + -- + -- (13) UNSLICED ONE-DIMENSIONAL ARRAY OBJECTS WHOSE TYPEMARKS + -- WERE DEFINED USING THE "BOX" SYMBOL + -- AND FOR WHICH THE COMPONENT TYPE IS 'CHARACTER' . + -- + -- (STRING LITERALS ARE THE ONLY AGGREGATES WE ARE USING + -- IN THIS TEST. TO FORCE SLIDING, THE LOWER LIMIT IMPLIED + -- BY THE TYPEMARK WILL NOT BE 1 .) + -- + -- + -- (14) SLICED ONE-DIMENSIONAL ARRAY OBJECTS WHOSE TYPEMARKS + -- WERE DEFINED USING THE "BOX" SYMBOL + -- AND FOR WHICH THE COMPONENT TYPE IS 'CHARACTER' . + -- + -- + -- + -- (-) SPECIAL CASES: SUPERLONG ARRAYS.. (TREATED FOR DYNAMIC + -- ARRAYS ONLY, + -- DIVISIONS C AND D .) + -- + -- + -- (-) THE DYNAMIC-ARRAY COUNTERPARTS OF THESE TESTS ARE IN DI- + -- VISIONS C (FOR NON-NULL ARRAYS) AND D (FOR NULL ARRAYS). + -- + -- + + + ------------------------------------------------------------------- + + -- (10) MULTIDIMENSIONAL ARRAY OBJECTS WHOSE TYPEMARKS WERE + -- DEFINED USING THE "BOX" COMPOUND SYMBOL. + -- (TWO-DIMENSIONAL ARRAYS OF INTEGERS.) + + DECLARE + + TYPE TABOX0 IS ARRAY( INTEGER RANGE <> , INTEGER RANGE <> + ) OF INTEGER ; + + SUBTYPE TABOX01 IS TABOX0( IDENT_INT(1)..IDENT_INT(0) , + IDENT_INT(0)..IDENT_INT(7) ); + SUBTYPE TABOX02 IS TABOX0 ; + + ARRX01 : TABOX01 ; + ARRX02 : TABOX02( IDENT_INT(7)..IDENT_INT(6) , + IDENT_INT(20)..IDENT_INT(27) ); + + BEGIN + + -- ARRAY ASSIGNMENT: + + ARRX02 := ARRX01 ; + + EXCEPTION + + WHEN OTHERS => + FAILED( "EXCEPTION RAISED - SUBTEST 10" ); + + END ; + + + ------------------------------------------------------------------- + + -- (3) UNSLICED ONE-DIMENSIONAL ARRAY OBJECTS WHOSE TYPEMARKS + -- WERE DEFINED WITHOUT EVER USING THE "BOX" SYMBOL + -- AND FOR WHICH THE COMPONENT TYPE IS NOT 'CHARACTER' . + -- ((ONE-DIMENSIONAL) ARRAYS OF INTEGERS.) + + DECLARE + + TYPE TA3 IS ARRAY( + INTEGER RANGE IDENT_INT(100)..IDENT_INT(99) + ) OF INTEGER ; + + SUBTYPE TA31 IS TA3 ; + SUBTYPE TA32 IS TA3 ; + + ARR31 : TA31 ; + ARR32 : TA32 ; + + BEGIN + + -- ARRAY ASSIGNMENT: + + ARR32 := ARR31 ; + + EXCEPTION + + WHEN OTHERS => + FAILED( "EXCEPTION RAISED - SUBTEST 3" ); + + END ; + + + ------------------------------------------------------------------- + + -- (12) SLICED ONE-DIMENSIONAL ARRAY OBJECTS WHOSE TYPEMARKS + -- WERE DEFINED USING THE "BOX" SYMBOL + -- AND FOR WHICH THE COMPONENT TYPE IS NOT 'CHARACTER' . + -- ((ONE-DIMENSIONAL) ARRAYS OF BOOLEANS.) + + DECLARE + + TYPE TABOX5 IS ARRAY( INTEGER RANGE <> ) OF BOOLEAN ; + + SUBTYPE TABOX51 IS TABOX5( IDENT_INT(1)..IDENT_INT(5) ); + + ARRX51 : TABOX51 ; + ARRX52 : TABOX5( IDENT_INT(5)..IDENT_INT(9) ); + + BEGIN + + -- INITIALIZATION OF RHS ARRAY: + + FOR I IN IDENT_INT(1)..IDENT_INT(5) LOOP + ARRX51( I ) := FALSE ; -- VALUES WILL BE: F T F F T + END LOOP; + + ARRX51(2) := TRUE ; + + ARRX51(5) := TRUE ; -- RHS VALUES ARE: F T F F T + + + -- INITIALIZATION OF LHS ARRAY: + + FOR I IN IDENT_INT(5)..IDENT_INT(9) LOOP + ARRX52( I ) := TRUE ; -- VALUES WILL BE: T F T T F + END LOOP; + + ARRX52(6) := FALSE ; + + ARRX52(9) := FALSE ; -- LHS VALUES ARE: T F T T F + + + -- NULL SLICE ASSIGNMENT: + + ARRX52( IDENT_INT(6)..IDENT_INT(5) ) := + ARRX51( + IDENT_INT(4)..IDENT_INT(3) ) ; + + + -- CHECKING THE VALUES AFTER THE SLICE ASSIGNMENT: + + IF ARRX52( 5 ) /= TRUE OR + ARRX52( 6 ) /= FALSE OR + ARRX52( 7 ) /= TRUE OR + ARRX52( 8 ) /= TRUE OR + ARRX52( 9 ) /= FALSE + THEN + FAILED( "SLICE ASSIGNMENT NOT CORRECT (VALUES)" ); + END IF; + + EXCEPTION + + WHEN OTHERS => + FAILED( "EXCEPTION RAISED - SUBTEST 12" ); + + END ; + + ------------------------------------------------------------------- + + + RESULT ; + + +END C52103P; diff --git a/gcc/testsuite/ada/acats/tests/c5/c52103q.ada b/gcc/testsuite/ada/acats/tests/c5/c52103q.ada new file mode 100644 index 000000000..919d037c6 --- /dev/null +++ b/gcc/testsuite/ada/acats/tests/c5/c52103q.ada @@ -0,0 +1,143 @@ +-- C52103Q.ADA + +-- Grant of Unlimited Rights +-- +-- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687, +-- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained +-- unlimited rights in the software and documentation contained herein. +-- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making +-- this public release, the Government intends to confer upon all +-- recipients unlimited rights equal to those held by the Government. +-- These rights include rights to use, duplicate, release or disclose the +-- released technical data and computer software in whole or in part, in +-- any manner and for any purpose whatsoever, and to have or permit others +-- to do so. +-- +-- DISCLAIMER +-- +-- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR +-- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED +-- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF 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 LENGTHS MUST MATCH IN ARRAY AND SLICE ASSIGNMENTS. +-- MORE SPECIFICALLY, TEST THAT ARRAY ASSIGNMENTS WITH MATCHING +-- LENGTHS DO NOT CAUSE CONSTRAINT_ERROR TO BE RAISED AND +-- ARE PERFORMED CORRECTLY. +-- (OVERLAPS BETWEEN THE OPERANDS OF THE ASSIGNMENT STATEMENT +-- ARE TREATED ELSWEWHERE.) + +-- THIS IS THE SECOND FILE IN +-- DIVISION D : NULL LENGTHS NOT DETERMINABLE STATICALLY. + + +-- RM 07/20/81 +-- SPS 2/18/83 + +WITH REPORT; +PROCEDURE C52103Q IS + + USE REPORT ; + +BEGIN + + TEST( "C52103Q" , "CHECK THAT IN ARRAY ASSIGNMENTS AND IN SLICE" & + " ASSIGNMENTS THE LENGTHS MUST MATCH" ); + + + -- ( EACH DIVISION COMPRISES 3 FILES, + -- COVERING RESPECTIVELY THE FIRST + -- 3 , NEXT 2 , AND LAST 3 OF THE 8 + -- SELECTIONS FOR THE DIVISION.) + + + ------------------------------------------------------------------- + + -- (5) UNSLICED ONE-DIMENSIONAL ARRAY OBJECTS WHOSE TYPEMARKS + -- WERE DEFINED WITHOUT EVER USING THE "BOX" SYMBOL + -- AND FOR WHICH THE COMPONENT TYPE IS 'CHARACTER' . + -- + + DECLARE + + TYPE TA51 IS ARRAY( + INTEGER RANGE IDENT_INT(11)..IDENT_INT(10) + ) OF CHARACTER ; + + ARR51 : TA51 ; + + BEGIN + + + -- ARRAY ASSIGNMENT (WITH STRING AGGREGATE): + + ARR51 := "" ; + + + -- CHECKING THE VALUES AFTER THE ASSIGNMENT: + + IF ARR51 /= "" + THEN + FAILED( "ARRAY ASSIGNMENT NOT CORRECT (5)" ); + END IF; + + + EXCEPTION + + WHEN OTHERS => + FAILED( "EXCEPTION RAISED - SUBTEST 5" ); + + END ; + + + ------------------------------------------------------------------- + + -- (14) SLICED ONE-DIMENSIONAL ARRAY OBJECTS WHOSE TYPEMARKS + -- WERE DEFINED USING THE "BOX" SYMBOL + -- AND FOR WHICH THE COMPONENT TYPE IS 'CHARACTER' . + + DECLARE + + TYPE TABOX4 IS ARRAY( INTEGER RANGE <> ) OF CHARACTER ; + + SUBTYPE TABOX42 IS TABOX4( IDENT_INT(11)..IDENT_INT(15) ); + + ARRX42 : TABOX42 ; + + BEGIN + + -- INITIALIZATION OF LHS ARRAY: + + ARRX42 := "QUINC" ; + + + -- NULL SLICE ASSIGNMENT: + + ARRX42( IDENT_INT(13)..IDENT_INT(12) ) := "" ; + + + -- CHECKING THE VALUES AFTER THE SLICE ASSIGNMENT: + + IF ARRX42 /= "QUINC" OR + ARRX42( IDENT_INT(11)..IDENT_INT(15) ) /= "QUINC" + THEN + FAILED( "SLICE ASSIGNMENT NOT CORRECT (14)" ); + END IF; + + EXCEPTION + + WHEN OTHERS => + FAILED( "EXCEPTION RAISED - SUBTEST 14" ); + + END ; + + + ------------------------------------------------------------------- + + + RESULT ; + + +END C52103Q; diff --git a/gcc/testsuite/ada/acats/tests/c5/c52103r.ada b/gcc/testsuite/ada/acats/tests/c5/c52103r.ada new file mode 100644 index 000000000..1daa11857 --- /dev/null +++ b/gcc/testsuite/ada/acats/tests/c5/c52103r.ada @@ -0,0 +1,181 @@ +-- C52103R.ADA + +-- Grant of Unlimited Rights +-- +-- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687, +-- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained +-- unlimited rights in the software and documentation contained herein. +-- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making +-- this public release, the Government intends to confer upon all +-- recipients unlimited rights equal to those held by the Government. +-- These rights include rights to use, duplicate, release or disclose the +-- released technical data and computer software in whole or in part, in +-- any manner and for any purpose whatsoever, and to have or permit others +-- to do so. +-- +-- DISCLAIMER +-- +-- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR +-- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED +-- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF 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 LENGTHS MUST MATCH IN ARRAY AND SLICE ASSIGNMENTS. +-- MORE SPECIFICALLY, TEST THAT ARRAY ASSIGNMENTS WITH MATCHING +-- LENGTHS DO NOT CAUSE CONSTRAINT_ERROR TO BE RAISED AND +-- ARE PERFORMED CORRECTLY. +-- (OVERLAPS BETWEEN THE OPERANDS OF THE ASSIGNMENT STATEMENT +-- ARE TREATED ELSWEWHERE.) + +-- THIS IS THE THIRD FILE IN +-- DIVISION D : NULL LENGTHS NOT DETERMINABLE STATICALLY. + + +-- RM 07/20/81 +-- SPS 2/18/83 + +WITH REPORT; +PROCEDURE C52103R IS + + USE REPORT ; + +BEGIN + + TEST( "C52103R" , "CHECK THAT IN ARRAY ASSIGNMENTS AND IN SLICE" & + " ASSIGNMENTS THE LENGTHS MUST MATCH" ); + + + -- ( EACH DIVISION COMPRISES 3 FILES, + -- COVERING RESPECTIVELY THE FIRST + -- 3 , NEXT 2 , AND LAST 3 OF THE 8 + -- SELECTIONS FOR THE DIVISION.) + + + ------------------------------------------------------------------- + + -- (7) UNSLICED OBJECTS OF THE PREDEFINED TYPE 'STRING' (BY + -- THEMSELVES). + + DECLARE + + ARR71 : STRING( IDENT_INT(1)..IDENT_INT(0) ) := "" ; + ARR72 : STRING( IDENT_INT(5)..IDENT_INT(4) ) ; + + BEGIN + + + -- STRING ASSIGNMENT: + + ARR72 := ARR71 ; + + + -- CHECKING THE VALUES AFTER THE STRING ASSIGNMENT: + + IF ARR72 /= "" + THEN + FAILED( "STRING ASSIGNMENT NOT CORRECT (7)" ); + END IF; + + EXCEPTION + + WHEN OTHERS => + FAILED( "EXCEPTION RAISED - SUBTEST 7" ); + + END ; + + + ------------------------------------------------------------------- + + -- (8) SLICED OBJECTS OF THE PREDEFINED TYPE 'STRING' , WITH + -- STRING LITERALS. + -- + + DECLARE + + ARR82 : STRING( IDENT_INT(5)..IDENT_INT(9) ) ; + + BEGIN + + + -- INITIALIZATION OF LHS ARRAY: + + ARR82( IDENT_INT(5)..IDENT_INT(9) ) := "QUINC" ; + + + -- STRING LITERAL ASSIGNMENT: + + ARR82( IDENT_INT(5)..IDENT_INT(9) ) + ( IDENT_INT(6)..IDENT_INT(9) ) + ( IDENT_INT(6)..IDENT_INT(5) ) := "" ; + + + -- CHECKING THE VALUES AFTER THE SLICE ASSIGNMENT: + + IF ARR82 /= "QUINC" OR + ARR82( IDENT_INT(5)..IDENT_INT(9) ) /= "QUINC" + THEN + FAILED( "SLICE ASSIGNMENT NOT CORRECT (8)" ); + END IF; + + EXCEPTION + + WHEN OTHERS => + FAILED( "EXCEPTION RAISED - SUBTEST 8" ); + + END ; + + ------------------------------------------------------------------- + + -- (9) SLICED OBJECTS OF THE PREDEFINED TYPE 'STRING' (BY + -- THEMSELVES). + -- + + DECLARE + + SUBTYPE TA92 IS STRING( IDENT_INT(5)..IDENT_INT(9) ) ; + + ARR91 : STRING( IDENT_INT(1)..IDENT_INT(5) ) := "ABCDE" ; + ARR92 : TA92 ; + + BEGIN + + + -- INITIALIZATION OF LHS ARRAY: + + ARR92( IDENT_INT(5)..IDENT_INT(9) ) := "QUINC" ; + + + -- STRING SLICE ASSIGNMENT: + + ARR92( IDENT_INT(5)..IDENT_INT(9) ) + ( IDENT_INT(6)..IDENT_INT(9) ) + ( IDENT_INT(8)..IDENT_INT(7) ) := + ARR91 + ( IDENT_INT(1)..IDENT_INT(5) ) + ( IDENT_INT(5)..IDENT_INT(4) ) ; + + + -- CHECKING THE VALUES AFTER THE SLICE ASSIGNMENT: + + IF ARR92 /= "QUINC" OR + ARR92( IDENT_INT(5)..IDENT_INT(9) ) /= "QUINC" + THEN + FAILED( "SLICE ASSIGNMENT NOT CORRECT (9)" ); + END IF; + + EXCEPTION + + WHEN OTHERS => + FAILED( "EXCEPTION RAISED - SUBTEST 9" ); + + END ; + + ------------------------------------------------------------------- + + + RESULT ; + + +END C52103R; diff --git a/gcc/testsuite/ada/acats/tests/c5/c52103x.ada b/gcc/testsuite/ada/acats/tests/c5/c52103x.ada new file mode 100644 index 000000000..f0fa56a2a --- /dev/null +++ b/gcc/testsuite/ada/acats/tests/c5/c52103x.ada @@ -0,0 +1,241 @@ +-- C52103X.ADA + +-- Grant of Unlimited Rights +-- +-- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687, +-- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained +-- unlimited rights in the software and documentation contained herein. +-- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making +-- this public release, the Government intends to confer upon all +-- recipients unlimited rights equal to those held by the Government. +-- These rights include rights to use, duplicate, release or disclose the +-- released technical data and computer software in whole or in part, in +-- any manner and for any purpose whatsoever, and to have or permit others +-- to do so. +-- +-- DISCLAIMER +-- +-- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR +-- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED +-- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF 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 LENGTHS MUST MATCH IN ARRAY AND SLICE ASSIGNMENTS. +-- MORE SPECIFICALLY, TEST THAT ARRAY ASSIGNMENTS WITH MATCHING +-- LENGTHS DO NOT CAUSE CONSTRAINT_ERROR TO BE RAISED AND +-- ARE PERFORMED CORRECTLY. +-- (OVERLAPS BETWEEN THE OPERANDS OF THE ASSIGNMENT STATEMENT +-- ARE TREATED ELSEWHERE.) + +-- THIS IS A SPECIAL CASE IN + +-- DIVISION C : NON-NULL ARRAYS WHOSE LENGTHS ARE NOT DETERMINABLE +-- STATICALLY + +-- WHICH TREATS ARRAYS OF LENGTH GREATER THAN INTEGER'LAST . +-- AN ADDITIONAL OBJECTIVE OF THIS TEST IS TO CHECK WHETHER LENGTH +-- COMPARISONS (AND LENGTH COMPUTATIONS) CAUSE +-- CONSTRAINT_ERROR TO BE RAISED. + +-- *** NOTE: This test has been modified since ACVC version 1.11 to -- 9X +-- *** remove incompatibilities associated with the transition -- 9X +-- *** to Ada 9X. -- 9X +-- *** -- 9X + +-- RM 07/31/81 +-- SPS 10/26/82 +-- JBG 06/15/83 +-- EG 11/02/84 +-- EG 10/28/85 FIX NUMERIC_ERROR/CONSTRAINT_ERROR ACCORDING TO +-- AI-00387. +-- JRK 06/24/86 FIXED COMMENTS ABOUT NUMERIC_ERROR/CONSTRAINT_ERROR. +-- MRM 03/30/93 REMOVED NUMERIC_ERROR FOR 9X COMPATIBILITY + +WITH REPORT; +PROCEDURE C52103X IS + + USE REPORT ; + +BEGIN + + TEST( "C52103X" , "CHECK THAT IN ARRAY ASSIGNMENTS AND IN SLICE " & + "ASSIGNMENTS, THE LENGTHS MUST MATCH; ALSO " & + "CHECK WHETHER CONSTRAINT_ERROR " & + "OR STORAGE_ERROR ARE RAISED FOR LARGE ARRAYS" ); + + -- IN THIS TEST WE CAN'T USE AGGREGATE ASSIGNMENT (EXCEPT WHEN + -- THE AGGREGATES ARE STRING LITERALS); THEREFORE: + -- + -- (1) ARRAYS WILL BE INITIALIZED BY INDIVIDUAL ASSIGNMENTS; + -- (2) CAN'T USE NON-NULL CONSTANT ARRAYS. + + + -- WE ASSUME THAT IN AN ARRAY_TYPE_DEFINITION THE INDEX PORTION + -- AND THE COMPONENT_TYPE PORTION ARE FUNCTIONALLY ORTHOGONAL + -- ALSO AT THE IMPLEMENTATION LEVEL, I.E. THAT THE CORRECTNESS + -- OF THE ACCESSING MECHANISM FOR ARRAYS DOES NOT DEPEND ON + -- COMPONENT_TYPE. ACCORDINGLY WE ARE TESTING FOR SOME BUT + -- NOT ALL KINDS OF COMPONENT_TYPE. (COMPONENT_TYPES INCLUDED: + -- INTEGER , CHARACTER , BOOLEAN .) + + + ------------------------------------------------------------------- + + -- (4) SLICED ONE-DIMENSIONAL ARRAY OBJECTS WHOSE TYPEMARKS + -- WERE DEFINED WITHOUT EVER USING THE "BOX" SYMBOL + -- AND FOR WHICH THE COMPONENT TYPE IS NOT 'CHARACTER' . + -- ((ONE-DIMENSIONAL) ARRAYS OF BOOLEANS.) + +CONSTR_ERR: -- THIS BLOCK CATCHES CONSTRAINT_ERROR + -- FOR THE TYPE DECLARATION. + BEGIN + +DCL_ARR: DECLARE -- THIS BLOCK DECLARES THE ARRAY TYPE + + TYPE TA42 IS ARRAY( + INTEGER RANGE IDENT_INT(-2)..IDENT_INT(INTEGER'LAST) + ) OF BOOLEAN ; + -- CONSTRAINT_ERROR MAY BE RAISED BY THE + -- ARRAY TYPE DECLARATION. + PRAGMA PACK (TA42); + + SUBTYPE TA41 IS TA42 ; + + BEGIN + + COMMENT ("NO CONSTRAINT_ERROR FOR TYPE " & + "WITH 'LENGTH = INTEGER'LAST + 3"); + +OBJ_DCL: DECLARE -- THIS BLOCK DECLARES TWO BOOLEAN ARRAYS THAT + -- HAVE INTEGER'LAST + 3 COMPONENTS; + -- STORAGE_ERROR MAY BE RAISED. + ARR41 : TA41 ; + ARR42 : TA42 ; + + BEGIN + + COMMENT ("NO STORAGE_ERROR OR CONSTRAINT_ERROR RAISED " & + "WHEN ALLOCATING TWO BIG BOOLEAN ARRAYS"); + -- INITIALIZATION OF RHS ARRAY: + + -- ONLY A SHORT INITIAL SEGMENT IS INITIALIZED, + -- SINCE A COMPLETE INITIALIZATION MIGHT TAKE TOO LONG + -- AND THE EXECUTION MIGHT BE ABORTED BEFORE THE LENGTH + -- COMPARISON OF THE ARRAY ASSIGNMENT IS ATTEMPTED. + +NO_EXCP: BEGIN -- NO EXCEPTION SHOULD OCCUR HERE. + FOR I IN IDENT_INT(-2)..IDENT_INT(2) LOOP + ARR41(I) := FALSE ; -- VALUES ARE:: FTFFT + END LOOP; + + ARR41(-1) := TRUE ; + + ARR41( 2) := TRUE ; -- RHS IS: F T F F T + + + -- INITIALIZATION OF UNUSED COMPONENT OF LHS ARRAY: + + ARR42( -2 ) := TRUE ; + + EXCEPTION + + WHEN CONSTRAINT_ERROR => + FAILED ("CONSTRAINT_ERROR RAISED WHEN " & + "ASSIGNING TO ARRAY COMPONENTS"); + WHEN OTHERS => + FAILED ("OTHER EXCEPTION RAISED - 1"); + + END NO_EXCP; + +DO_SLICE: BEGIN + -- SLICE ASSIGNMENT: + + ARR42( IDENT_INT(-1)..IDENT_INT(INTEGER'LAST )) := + ARR41( + IDENT_INT(-2)..IDENT_INT(INTEGER'LAST-1)) ; + + COMMENT ("NO EXCEPTION RAISED DURING SLICE " & + "ASSIGNMENT"); + + -- CHECKING THE VALUES AFTER THE SLICE ASSIGNMENT: + + CHK_SLICE: BEGIN + FOR I IN IDENT_INT(-1)..IDENT_INT(2) LOOP + + IF ARR42( I ) /= FALSE AND I /= 0 + THEN + FAILED( "SLICE ASSIGNMENT NOT " & + "CORRECT (VALUES)" ); + ELSIF ARR42( I ) /= TRUE AND I = 0 + THEN + FAILED( "SLICE ASSIGNMENT NOT " & + "CORRECT (VALUES)" ); + END IF; + + END LOOP; + + IF ARR42( -2 ) /= TRUE + THEN + FAILED( "SLICE ASSIGNMENT NOT CORRECT " & + "(SLIDING)" ); + END IF; + + EXCEPTION + + WHEN OTHERS => + FAILED ("SOME EXCEPTION RAISED - 2"); + + END CHK_SLICE; + + EXCEPTION + + WHEN CONSTRAINT_ERROR => + COMMENT ("CONSTRAINT_ERROR RAISED DURING " & + "SLICE ASSIGNMENT"); + WHEN STORAGE_ERROR => + COMMENT ("STORAGE_ERROR RAISED DURING SLICE " & + "ASSIGNMENT"); + WHEN OTHERS => + FAILED ("SOME EXCEPTION DURING SLICE " & + "ASSIGNMENT"); + END DO_SLICE; + + END OBJ_DCL; + + EXCEPTION + + WHEN STORAGE_ERROR => + COMMENT ("STORAGE_ERROR RAISED WHEN DECLARING " & + "TWO PACKED BOOLEAN ARRAYS WITH " & + "INTEGER'LAST + 3 COMPONENTS"); + WHEN CONSTRAINT_ERROR => + COMMENT ("CONSTRAINT_ERROR RAISED WHEN DECLARING " & + "TWO PACKED BOOLEAN ARRAYS WITH " & + "INTEGER'LAST + 3 COMPONENTS"); + WHEN OTHERS => + FAILED ("SOME EXCEPTION RAISED - 3"); + + END DCL_ARR; + + EXCEPTION + + + WHEN CONSTRAINT_ERROR => + COMMENT ("CONSTRAINT_ERROR RAISED WHEN DECLARING AN " & + "ARRAY TYPE WITH INTEGER'LAST + 3 COMPONENTS"); + + WHEN STORAGE_ERROR => + FAILED ("STORAGE_ERROR RAISED FOR TYPE DECLARATION"); + + WHEN OTHERS => + FAILED ("OTHER EXCEPTION RAISED - 4"); + + END CONSTR_ERR; + + + RESULT ; + + +END C52103X; diff --git a/gcc/testsuite/ada/acats/tests/c5/c52104a.ada b/gcc/testsuite/ada/acats/tests/c5/c52104a.ada new file mode 100644 index 000000000..c71408cc3 --- /dev/null +++ b/gcc/testsuite/ada/acats/tests/c5/c52104a.ada @@ -0,0 +1,343 @@ +-- C52104A.ADA + +-- Grant of Unlimited Rights +-- +-- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687, +-- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained +-- unlimited rights in the software and documentation contained herein. +-- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making +-- this public release, the Government intends to confer upon all +-- recipients unlimited rights equal to those held by the Government. +-- These rights include rights to use, duplicate, release or disclose the +-- released technical data and computer software in whole or in part, in +-- any manner and for any purpose whatsoever, and to have or permit others +-- to do so. +-- +-- DISCLAIMER +-- +-- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR +-- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED +-- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF 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 LENGTHS MUST MATCH IN ARRAY AND SLICE ASSIGNMENTS. +-- MORE SPECIFICALLY, TEST THAT ATTEMPTED ASSIGNMENTS BETWEEN +-- ARRAYS WITH NON-MATCHING LENGTHS LEAVE THE DESTINATION ARRAY +-- INTACT AND CAUSE CONSTRAINT_ERROR TO BE RAISED. +-- (OVERLAPS BETWEEN THE OPERANDS OF THE ASSIGNMENT STATEMENT +-- ARE TREATED ELSEWHERE.) + +-- DIVISION A : STATICALLY-DETERMINABLE NON-NULL LENGTHS. + + +-- RM 07/20/81 +-- SPS 3/22/83 + +WITH REPORT; +PROCEDURE C52104A IS + + USE REPORT ; + +BEGIN + + TEST( "C52104A" , "CHECK THAT IN ARRAY ASSIGNMENTS AND IN SLICE" & + " ASSIGNMENTS THE LENGTHS MUST MATCH" ); + + + -- IN THIS TEST WE CAN'T USE AGGREGATE ASSIGNMENT (EXCEPT WHEN + -- THE AGGREGATES ARE STRING LITERALS); THEREFORE: + -- + -- (1) ARRAYS WILL BE INITIALIZED BY INDIVIDUAL ASSIGNMENTS; + -- (2) CAN'T USE NON-NULL CONSTANT ARRAYS. + + + -- WE ASSUME THAT IN AN ARRAY_TYPE_DEFINITION THE INDEX PORTION + -- AND THE COMPONENT_TYPE PORTION ARE FUNCTIONALLY ORTHOGONAL + -- ALSO AT THE IMPLEMENTATION LEVEL, I.E. THAT THE CORRECTNESS + -- OF THE ACCESSING MECHANISM FOR ARRAYS DOES NOT DEPEND ON + -- COMPONENT_TYPE. ACCORDINGLY WE ARE TESTING FOR SOME BUT + -- NOT ALL KINDS OF COMPONENT_TYPE. (COMPONENT_TYPES INCLUDED: + -- INTEGER , CHARACTER , BOOLEAN .) + + + -- CASES DISTINGUISHED: ( 8 SELECTED CASES ARE IMPLEMENTED) + -- + -- ( THE 8 SELECTIONS ARE THE 5-CASE + -- SERIES 10-11-12-13-14 FOLLOWED + -- BY 7 , 8 , 9 (IN THIS ORDER). ) + -- + -- + -- ( EACH DIVISION COMPRISES 3 FILES, + -- COVERING RESPECTIVELY THE FIRST + -- 3 , NEXT 2 , AND LAST 3 OF THE 8 + -- SELECTIONS FOR THE DIVISION.) + -- + -- + -- (1..6) (DO NOT APPLY TO NON-MATCHING OBJECTS, SINCE WE WANT + -- THE OBJECTS TO HAVE THE S A M E BASE TYPE.) + -- + -- + -- (7) UNSLICED OBJECTS OF THE PREDEFINED TYPE 'STRING' (BY + -- THEMSELVES). + -- + -- + -- (8) SLICED OBJECTS OF THE PREDEFINED TYPE 'STRING' , WITH + -- STRING LITERALS. + -- + -- + -- (9) SLICED OBJECTS OF THE PREDEFINED TYPE 'STRING' (BY + -- THEMSELVES). + -- + -- + -- (-) CONSTRAINABLE TYPES: ONLY SUBTESTS 2, 3, 4, 5, 6 + -- WILL BE REPLICATED -- AS SUBTESTS 10, 11, 12, 13, 14 . + -- + -- + -- (10) MULTIDIMENSIONAL ARRAY OBJECTS WHOSE TYPEMARKS WERE + -- DEFINED USING THE "BOX" COMPOUND SYMBOL. + -- (TWO-DIMENSIONAL ARRAYS OF INTEGERS.) + -- + -- + -- (11) UNSLICED ONE-DIMENSIONAL ARRAY OBJECTS WHOSE TYPEMARKS + -- WERE DEFINED USING THE "BOX" SYMBOL + -- AND FOR WHICH THE COMPONENT TYPE IS NOT 'CHARACTER' . + -- ((ONE-DIMENSIONAL) ARRAYS OF INTEGERS.) + -- + -- + -- (12) SLICED ONE-DIMENSIONAL ARRAY OBJECTS WHOSE TYPEMARKS + -- WERE DEFINED USING THE "BOX" SYMBOL + -- AND FOR WHICH THE COMPONENT TYPE IS NOT 'CHARACTER' . + -- ((ONE-DIMENSIONAL) ARRAYS OF BOOLEANS.) + -- + -- + -- (13) UNSLICED ONE-DIMENSIONAL ARRAY OBJECTS WHOSE TYPEMARKS + -- WERE DEFINED USING THE "BOX" SYMBOL + -- AND FOR WHICH THE COMPONENT TYPE IS 'CHARACTER' . + -- + -- (STRING LITERALS ARE THE ONLY AGGREGATES WE ARE USING + -- IN THIS TEST. TO FORCE SLIDING, THE LOWER LIMIT IMPLIED + -- BY THE TYPEMARK WILL NOT BE 1 .) + -- + -- + -- (14) SLICED ONE-DIMENSIONAL ARRAY OBJECTS WHOSE TYPEMARKS + -- WERE DEFINED USING THE "BOX" SYMBOL + -- AND FOR WHICH THE COMPONENT TYPE IS 'CHARACTER' . + -- + -- + -- + -- (-) SPECIAL CASES: NULL ARRAYS....... TREATED IN DIVISION B. + -- SUPERLONG ARRAYS.. (TREATED FOR DYNAMIC + -- ARRAYS ONLY, + -- DIVISIONS C AND D .) + -- + -- + -- (-) THE DYNAMIC-ARRAY COUNTERPARTS OF THESE TESTS ARE IN DI- + -- VISIONS C (FOR NON-NULL ARRAYS) AND D (FOR NULL ARRAYS). + -- + -- + + + ------------------------------------------------------------------- + + -- (1..6: NOT APPLICABLE) + -- + -- + + ------------------------------------------------------------------- + + -- (10) MULTIDIMENSIONAL ARRAY OBJECTS WHOSE TYPEMARKS WERE + -- DEFINED USING THE "BOX" COMPOUND SYMBOL. + -- (TWO-DIMENSIONAL ARRAYS OF INTEGERS.) + + DECLARE + + TYPE TABOX0 IS ARRAY( INTEGER RANGE <> , INTEGER RANGE <> + ) OF INTEGER ; + + SUBTYPE TABOX01 IS TABOX0( 1..5 , 0..7 ); + SUBTYPE TABOX02 IS TABOX0( 0..5 , 2..9 ); + + ARRX01 : TABOX01 ; + ARRX02 : TABOX02 ; + + BEGIN + + -- INITIALIZATION OF RHS ARRAY: + + FOR I IN 1..5 LOOP + + FOR J IN 0..7 LOOP + ARRX01( I , J ) := I * I * J ; + END LOOP; + + END LOOP; + + + -- INITIALIZATION OF LHS ARRAY: + + FOR I IN 0..5 LOOP + + FOR J IN 2..9 LOOP + ARRX02( I , J ) := I * I * J * 3 ; + END LOOP; + + END LOOP; + + + -- ARRAY ASSIGNMENT: + + ARRX02 := ARRX01 ; + FAILED( "EXCEPTION NOT RAISED - SUBTEST 10" ); + + EXCEPTION + + WHEN CONSTRAINT_ERROR => + + -- CHECKING THE VALUES AFTER THE ARRAY ASSIGNMENT: + + FOR I IN 0..5 LOOP + + FOR J IN 2..9 LOOP + + IF ARRX02( I , J ) /= I * I * J * 3 + THEN + FAILED( "ORIG. VALUE ALTERED (10)" ); + END IF; + + END LOOP; + + END LOOP; + + WHEN OTHERS => + FAILED( "WRONG EXCEPTION RAISED - SUBTEST 10" ); + + END ; + + + ------------------------------------------------------------------- + + -- (11) UNSLICED ONE-DIMENSIONAL ARRAY OBJECTS WHOSE TYPEMARKS + -- WERE DEFINED USING THE "BOX" SYMBOL + -- AND FOR WHICH THE COMPONENT TYPE IS NOT 'CHARACTER' . + -- ((ONE-DIMENSIONAL) ARRAYS OF INTEGERS.) + + DECLARE + + TYPE TABOX1 IS ARRAY( INTEGER RANGE <> ) OF INTEGER ; + + SUBTYPE TABOX11 IS TABOX1( 1..5 ) ; + + ARRX11 : TABOX11 ; + ARRX12 : TABOX1( 6..9 ); + + BEGIN + + -- INITIALIZATION OF RHS ARRAY: + + FOR I IN 1..5 LOOP + + ARRX11( I ) := I * I ; + + END LOOP; + + + -- INITIALIZATION OF LHS ARRAY: + + FOR I IN 6..9 LOOP + ARRX12( I ) := I * I * 3 ; + END LOOP; + + + -- ARRAY ASSIGNMENT: + + ARRX12 := ARRX11 ; + FAILED( "EXCEPTION NOT RAISED - SUBTEST 11" ); + + EXCEPTION + + WHEN CONSTRAINT_ERROR => + + -- CHECKING THE VALUES AFTER THE ARRAY ASSIGNMENT: + + FOR I IN 6..9 LOOP + + IF ARRX12( I ) /= I * I * 3 + THEN + FAILED( "ORIG. VALUE ALTERED (11)" ); + END IF; + + END LOOP; + + WHEN OTHERS => + FAILED( "WRONG EXCEPTION RAISED - SUBTEST 11" ); + + END ; + + + ------------------------------------------------------------------- + + -- (12) SLICED ONE-DIMENSIONAL ARRAY OBJECTS WHOSE TYPEMARKS + -- WERE DEFINED USING THE "BOX" SYMBOL + -- AND FOR WHICH THE COMPONENT TYPE IS NOT 'CHARACTER' . + -- ((ONE-DIMENSIONAL) ARRAYS OF BOOLEANS.) + + DECLARE + + TYPE TABOX5 IS ARRAY( INTEGER RANGE <> ) OF BOOLEAN ; + + SUBTYPE TABOX51 IS TABOX5( 1..5 ); + + ARRX51 : TABOX51 ; + ARRX52 : TABOX5( 5..9 ); + + BEGIN + + -- INITIALIZATION OF LHS ARRAY: + + FOR I IN 5..9 LOOP + ARRX52( I ) := FALSE ; + END LOOP; + + + -- INITIALIZATION OF RHS ARRAY: + + FOR I IN 1..5 LOOP + ARRX51( I ) := TRUE ; + END LOOP; + + + -- SLICE ASSIGNMENT: + + ARRX52(6..9) := ARRX51(3..3) ; + FAILED( "EXCEPTION NOT RAISED (12)" ); + + EXCEPTION + + WHEN CONSTRAINT_ERROR => + + -- CHECKING THE VALUES AFTER THE SLICE ASSIGNMENT: + + FOR I IN 5..9 LOOP + + IF ARRX52( I ) /= FALSE + THEN + FAILED( "LHS ARRAY ALTERED ( 12 ) " ); + END IF; + + END LOOP; + + WHEN OTHERS => + FAILED( "EXCEPTION RAISED - SUBTEST 12" ); + + END ; + + + ------------------------------------------------------------------- + + + RESULT ; + + +END C52104A; diff --git a/gcc/testsuite/ada/acats/tests/c5/c52104b.ada b/gcc/testsuite/ada/acats/tests/c5/c52104b.ada new file mode 100644 index 000000000..d2f426189 --- /dev/null +++ b/gcc/testsuite/ada/acats/tests/c5/c52104b.ada @@ -0,0 +1,144 @@ +-- C52104B.ADA + +-- Grant of Unlimited Rights +-- +-- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687, +-- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained +-- unlimited rights in the software and documentation contained herein. +-- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making +-- this public release, the Government intends to confer upon all +-- recipients unlimited rights equal to those held by the Government. +-- These rights include rights to use, duplicate, release or disclose the +-- released technical data and computer software in whole or in part, in +-- any manner and for any purpose whatsoever, and to have or permit others +-- to do so. +-- +-- DISCLAIMER +-- +-- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR +-- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED +-- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF 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 LENGTHS MUST MATCH IN ARRAY AND SLICE ASSIGNMENTS. +-- MORE SPECIFICALLY, TEST THAT ATTEMPTED ASSIGNMENTS BETWEEN +-- ARRAYS WITH NON-MATCHING LENGTHS LEAVE THE DESTINATION ARRAY +-- INTACT AND CAUSE CONSTRAINT_ERROR TO BE RAISED. +-- (OVERLAPS BETWEEN THE OPERANDS OF THE ASSIGNMENT STATEMENT +-- ARE TREATED ELSEWHERE.) + +-- THIS IS THE SECOND FILE IN +-- DIVISION A : STATICALLY-DETERMINABLE NON-NULL LENGTHS. + + +-- RM 07/20/81 +-- SPS 3/22/83 + +WITH REPORT; +PROCEDURE C52104B IS + + USE REPORT ; + +BEGIN + + TEST( "C52104B" , "CHECK THAT IN ARRAY ASSIGNMENTS AND IN SLICE" & + " ASSIGNMENTS THE LENGTHS MUST MATCH" ); + + + -- ( EACH DIVISION COMPRISES 3 FILES, + -- COVERING RESPECTIVELY THE FIRST + -- 3 , NEXT 2 , AND LAST 3 OF THE 8 + -- SELECTIONS FOR THE DIVISION.) + + + ------------------------------------------------------------------- + + -- (13) UNSLICED ONE-DIMENSIONAL ARRAY OBJECTS WHOSE TYPEMARKS + -- WERE DEFINED USING THE "BOX" SYMBOL + -- AND FOR WHICH THE COMPONENT TYPE IS 'CHARACTER' . + + DECLARE + + TYPE TABOX3 IS ARRAY( INTEGER RANGE <> ) OF CHARACTER ; + + ARRX31 : TABOX3( 2..6 ) := "QUINC" ; + + BEGIN + + + -- ARRAY ASSIGNMENT (WITH STRING AGGREGATE): + + ARRX31 := "ABCD" ; + FAILED( "NO EXCEPTION RAISED (13)" ); + + EXCEPTION + + WHEN CONSTRAINT_ERROR => + + -- CHECKING THE VALUES AFTER THE ASSIGNMENT: + + IF ARRX31 /= "QUINC" OR + ARRX31( 2..6 ) /= "QUINC" + THEN + FAILED( "LHS ARRAY ALTERED (13)" ); + END IF; + + WHEN OTHERS => + FAILED( "WRONG EXCEPTION RAISED - SUBTEST 13" ); + + END ; + + + ------------------------------------------------------------------- + + -- (14) SLICED ONE-DIMENSIONAL ARRAY OBJECTS WHOSE TYPEMARKS + -- WERE DEFINED USING THE "BOX" SYMBOL + -- AND FOR WHICH THE COMPONENT TYPE IS 'CHARACTER' . + + DECLARE + + TYPE TABOX4 IS ARRAY( INTEGER RANGE <> ) OF CHARACTER ; + + SUBTYPE TABOX42 IS TABOX4( 5..9 ); + + ARRX42 : TABOX42 ; + + BEGIN + + -- INITIALIZATION OF LHS ARRAY: + + ARRX42 := "QUINC" ; + + + -- SLICE ASSIGNMENT: + + ARRX42( 6..9 ) := "ABCDEFGH" ; + FAILED( "NO EXCEPTION RAISED (14)" ); + + EXCEPTION + + WHEN CONSTRAINT_ERROR => + + -- CHECKING THE VALUES AFTER THE ASSIGNMENT: + + IF ARRX42 /= "QUINC" OR + ARRX42( 5..9 ) /= "QUINC" + THEN + FAILED( "LHS ARRAY ALTERED (14)" ); + END IF; + + WHEN OTHERS => + FAILED( "WRONG EXCEPTION RAISED - SUBTEST 14" ); + + END ; + + + ------------------------------------------------------------------- + + + RESULT ; + + +END C52104B; diff --git a/gcc/testsuite/ada/acats/tests/c5/c52104c.ada b/gcc/testsuite/ada/acats/tests/c5/c52104c.ada new file mode 100644 index 000000000..34cb2aaf2 --- /dev/null +++ b/gcc/testsuite/ada/acats/tests/c5/c52104c.ada @@ -0,0 +1,178 @@ +-- C52104C.ADA + +-- Grant of Unlimited Rights +-- +-- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687, +-- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained +-- unlimited rights in the software and documentation contained herein. +-- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making +-- this public release, the Government intends to confer upon all +-- recipients unlimited rights equal to those held by the Government. +-- These rights include rights to use, duplicate, release or disclose the +-- released technical data and computer software in whole or in part, in +-- any manner and for any purpose whatsoever, and to have or permit others +-- to do so. +-- +-- DISCLAIMER +-- +-- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR +-- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED +-- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF 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 LENGTHS MUST MATCH IN ARRAY AND SLICE ASSIGNMENTS. +-- MORE SPECIFICALLY, TEST THAT ATTEMPTED ASSIGNMENTS BETWEEN +-- ARRAYS WITH NON-MATCHING LENGTHS LEAVE THE DESTINATION ARRAY +-- INTACT AND CAUSE CONSTRAINT_ERROR TO BE RAISED. +-- (OVERLAPS BETWEEN THE OPERANDS OF THE ASSIGNMENT STATEMENT +-- ARE TREATED ELSEWHERE.) + +-- THIS IS THE THIRD FILE IN +-- DIVISION A : STATICALLY-DETERMINABLE NON-NULL LENGTHS. + + +-- RM 07/20/81 +-- SPS 3/22/83 + +WITH REPORT; +PROCEDURE C52104C IS + + USE REPORT ; + +BEGIN + + TEST( "C52104C" , "CHECK THAT IN ARRAY ASSIGNMENTS AND IN SLICE" & + " ASSIGNMENTS THE LENGTHS MUST MATCH" ); + + + -- ( EACH DIVISION COMPRISES 3 FILES, + -- COVERING RESPECTIVELY THE FIRST + -- 3 , NEXT 2 , AND LAST 3 OF THE 8 + -- SELECTIONS FOR THE DIVISION.) + + + ------------------------------------------------------------------- + + -- (7) UNSLICED OBJECTS OF THE PREDEFINED TYPE 'STRING' (BY + -- THEMSELVES). + + DECLARE + + ARR71 : STRING( 1..5 ) := "ABCDE" ; + ARR72 : STRING( 5..8 ) := "FGHI" ; + + BEGIN + + + -- STRING ASSIGNMENT: + + ARR72 := ARR71 ; + FAILED( "EXCEPTION NOT RAISED - SUBTEST 7" ); + + EXCEPTION + + WHEN CONSTRAINT_ERROR => + + -- CHECKING THE VALUES AFTER THE STRING ASSIGNMENT: + + IF ARR72 /= "FGHI" + THEN + FAILED( "ORIGINAL VALUE ALTERED (7)" ); + END IF; + + WHEN OTHERS => + FAILED( "WRONG EXCEPTION RAISED - SUBTEST 7" ); + + END ; + + + ------------------------------------------------------------------- + + + -- (8) SLICED OBJECTS OF THE PREDEFINED TYPE 'STRING' , WITH + -- STRING LITERALS. + -- + + DECLARE + + ARR82 : STRING( 5..9 ) := "QBCDE" ; + + BEGIN + + + -- STRING LITERAL ASSIGNMENT: + + ARR82( 5..9 )( 6..9 ) := "EIN" ; + FAILED( "EXCEPTION NOT RAISED - SUBTEST 8" ); + + EXCEPTION + + WHEN CONSTRAINT_ERROR => + + -- CHECKING THE VALUES AFTER THE SLICE ASSIGNMENT: + + IF ARR82 /= "QBCDE" OR + ARR82( 5..9 ) /= "QBCDE" + THEN + FAILED( "LHS ARRAY ALTERED (8)" ); + END IF; + + WHEN OTHERS => + FAILED( "WRONG EXCEPTION RAISED - SUBTEST 8" ); + + END ; + + + ------------------------------------------------------------------- + + -- (9) SLICED OBJECTS OF THE PREDEFINED TYPE 'STRING' (BY + -- THEMSELVES). + -- + + DECLARE + + SUBTYPE TA92 IS STRING( 5..9 ) ; + + ARR91 : STRING( 1..7 ) := "ABCDEFG" ; + ARR92 : TA92 ; + + BEGIN + + + -- INITIALIZATION OF LHS ARRAY: + + ARR92( 5..9 ) := "QUINC" ; + + + -- STRING SLICE ASSIGNMENT: + + ARR92( 5..9 )( 6..9 ) := ARR91( 1..7 )( 1..6 )( 1..6 ) ; + FAILED( "EXCEPTION NOT RAISED - SUBTEST 9" ); + + EXCEPTION + + WHEN CONSTRAINT_ERROR => + + -- CHECKING THE VALUES AFTER THE SLICE ASSIGNMENT: + + IF ARR92 /= "QUINC" OR + ARR92( 5..9 ) /= "QUINC" + THEN + FAILED( "LHS VALUE ALTERED (9)" ); + END IF; + + WHEN OTHERS => + FAILED( "WRONG EXCEPTION RAISED - SUBTEST 9" ); + + END ; + + + ------------------------------------------------------------------- + + + RESULT ; + + +END C52104C; diff --git a/gcc/testsuite/ada/acats/tests/c5/c52104f.ada b/gcc/testsuite/ada/acats/tests/c5/c52104f.ada new file mode 100644 index 000000000..a6e8a392e --- /dev/null +++ b/gcc/testsuite/ada/acats/tests/c5/c52104f.ada @@ -0,0 +1,292 @@ +-- C52104F.ADA + +-- Grant of Unlimited Rights +-- +-- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687, +-- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained +-- unlimited rights in the software and documentation contained herein. +-- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making +-- this public release, the Government intends to confer upon all +-- recipients unlimited rights equal to those held by the Government. +-- These rights include rights to use, duplicate, release or disclose the +-- released technical data and computer software in whole or in part, in +-- any manner and for any purpose whatsoever, and to have or permit others +-- to do so. +-- +-- DISCLAIMER +-- +-- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR +-- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED +-- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF 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 LENGTHS MUST MATCH IN ARRAY AND SLICE ASSIGNMENTS. +-- MORE SPECIFICALLY, TEST THAT ATTEMPTED ASSIGNMENTS BETWEEN +-- ARRAYS WITH NON-MATCHING LENGTHS LEAVE THE DESTINATION ARRAY +-- INTACT AND CAUSE CONSTRAINT_ERROR TO BE RAISED. +-- (OVERLAPS BETWEEN THE OPERANDS OF THE ASSIGNMENT STATEMENT +-- ARE TREATED ELSWEWHERE.) + +-- DIVISION B : STATICALLY-DETERMINABLE NULL LENGTHS. + + +-- RM 07/20/81 +-- SPS 10/27/82 + +WITH REPORT; +PROCEDURE C52104F IS + + USE REPORT ; + +BEGIN + + TEST( "C52104F" , "CHECK THAT IN ARRAY ASSIGNMENTS AND IN SLICE" & + " ASSIGNMENTS THE LENGTHS MUST MATCH" ); + + + -- IN THIS TEST WE CAN'T USE AGGREGATE ASSIGNMENT (EXCEPT WHEN + -- THE AGGREGATES ARE STRING LITERALS); THEREFORE: + -- + -- (1) ARRAYS WILL BE INITIALIZED BY INDIVIDUAL ASSIGNMENTS; + -- (2) CAN'T USE NON-NULL CONSTANT ARRAYS. + + + -- WE ASSUME THAT IN AN ARRAY_TYPE_DEFINITION THE INDEX PORTION + -- AND THE COMPONENT_TYPE PORTION ARE FUNCTIONALLY ORTHOGONAL + -- ALSO AT THE IMPLEMENTATION LEVEL, I.E. THAT THE CORRECTNESS + -- OF THE ACCESSING MECHANISM FOR ARRAYS DOES NOT DEPEND ON + -- COMPONENT_TYPE. ACCORDINGLY WE ARE TESTING FOR SOME BUT + -- NOT ALL KINDS OF COMPONENT_TYPE. (COMPONENT_TYPES INCLUDED: + -- INTEGER , CHARACTER , BOOLEAN .) + + + -- CASES DISTINGUISHED: ( 8 SELECTED CASES ARE IMPLEMENTED) + -- + -- ( THE 8 SELECTIONS ARE THE 5-CASE + -- SERIES 10-11-12-13-14 FOLLOWED + -- BY 7 , 8 , 9 (IN THIS ORDER). ) + -- + -- + -- ( EACH DIVISION COMPRISES 3 FILES, + -- COVERING RESPECTIVELY THE FIRST + -- 3 , NEXT 2 , AND LAST 3 OF THE 8 + -- SELECTIONS FOR THE DIVISION.) + -- + -- + -- (1..6) (DO NOT APPLY TO NON-MATCHING OBJECTS, SINCE WE WANT + -- THE OBJECTS TO HAVE THE S A M E BASE TYPE.) + -- + -- + -- (7) UNSLICED OBJECTS OF THE PREDEFINED TYPE 'STRING' (BY + -- THEMSELVES). + -- + -- + -- (8) SLICED OBJECTS OF THE PREDEFINED TYPE 'STRING' , WITH + -- STRING LITERALS. + -- + -- + -- (9) SLICED OBJECTS OF THE PREDEFINED TYPE 'STRING' (BY + -- THEMSELVES). + -- + -- + -- (-) CONSTRAINABLE TYPES: ONLY SUBTESTS 2, 3, 4, 5, 6 + -- WILL BE REPLICATED -- AS SUBTESTS 10, 11, 12, 13, 14 . + -- + -- + -- (10) MULTIDIMENSIONAL ARRAY OBJECTS WHOSE TYPEMARKS WERE + -- DEFINED USING THE "BOX" COMPOUND SYMBOL. + -- (TWO-DIMENSIONAL ARRAYS OF INTEGERS.) + -- + -- + -- (11) UNSLICED ONE-DIMENSIONAL ARRAY OBJECTS WHOSE TYPEMARKS + -- WERE DEFINED USING THE "BOX" SYMBOL + -- AND FOR WHICH THE COMPONENT TYPE IS NOT 'CHARACTER' . + -- ((ONE-DIMENSIONAL) ARRAYS OF INTEGERS.) + -- + -- + -- (12) SLICED ONE-DIMENSIONAL ARRAY OBJECTS WHOSE TYPEMARKS + -- WERE DEFINED USING THE "BOX" SYMBOL + -- AND FOR WHICH THE COMPONENT TYPE IS NOT 'CHARACTER' . + -- ((ONE-DIMENSIONAL) ARRAYS OF BOOLEANS.) + -- + -- + -- (13) UNSLICED ONE-DIMENSIONAL ARRAY OBJECTS WHOSE TYPEMARKS + -- WERE DEFINED USING THE "BOX" SYMBOL + -- AND FOR WHICH THE COMPONENT TYPE IS 'CHARACTER' . + -- + -- (STRING LITERALS ARE THE ONLY AGGREGATES WE ARE USING + -- IN THIS TEST. TO FORCE SLIDING, THE LOWER LIMIT IMPLIED + -- BY THE TYPEMARK WILL NOT BE 1 .) + -- + -- + -- (14) SLICED ONE-DIMENSIONAL ARRAY OBJECTS WHOSE TYPEMARKS + -- WERE DEFINED USING THE "BOX" SYMBOL + -- AND FOR WHICH THE COMPONENT TYPE IS 'CHARACTER' . + -- + -- + -- + -- (-) SPECIAL CASES: SUPERLONG ARRAYS.. (TREATED FOR DYNAMIC + -- ARRAYS ONLY, + -- DIVISIONS C AND D .) + -- + -- + -- (-) THE DYNAMIC-ARRAY COUNTERPARTS OF THESE TESTS ARE IN DI- + -- VISIONS C (FOR NON-NULL ARRAYS) AND D (FOR NULL ARRAYS). + -- + -- + + + ------------------------------------------------------------------- + + -- (1 .. 6: NOT APPLICABLE) + -- + -- + + ------------------------------------------------------------------- + + -- (10) MULTIDIMENSIONAL ARRAY OBJECTS WHOSE TYPEMARKS WERE + -- DEFINED USING THE "BOX" COMPOUND SYMBOL. + -- (TWO-DIMENSIONAL ARRAYS OF INTEGERS.) + + DECLARE + + TYPE TABOX0 IS ARRAY( INTEGER RANGE <> , INTEGER RANGE <> + ) OF INTEGER ; + + SUBTYPE TABOX01 IS TABOX0( 1..1 , 0..7 ); + SUBTYPE TABOX02 IS TABOX0 ; + + ARRX01 : TABOX01 ; + ARRX02 : TABOX02( 1..0 , 0..7 ); + + BEGIN + + -- ARRAY ASSIGNMENT: + + ARRX02 := ARRX01 ; + FAILED( "EXCEPTION NOT RAISED - SUBTEST 10" ); + + EXCEPTION + + WHEN CONSTRAINT_ERROR => + + NULL ; + + WHEN OTHERS => + + FAILED( "WRONG EXCEPTION RAISED - SUBTEST 10" ); + + END ; + + + ------------------------------------------------------------------- + + -- (11) UNSLICED ONE-DIMENSIONAL ARRAY OBJECTS WHOSE TYPEMARKS + -- WERE DEFINED USING THE "BOX" SYMBOL + -- AND FOR WHICH THE COMPONENT TYPE IS NOT 'CHARACTER' . + -- ((ONE-DIMENSIONAL) ARRAYS OF INTEGERS.) + + DECLARE + + TYPE TABOX1 IS ARRAY( INTEGER RANGE <> ) OF INTEGER ; + + SUBTYPE TABOX11 IS TABOX1( 4..5 ) ; + + ARRX11 : TABOX11 ; + ARRX12 : TABOX1( 5..4 ); + + BEGIN + + -- ARRAY ASSIGNMENT: + + ARRX12 := ARRX11 ; + FAILED( "EXCEPTION NOT RAISED - SUBTEST 11" ); + + EXCEPTION + + WHEN CONSTRAINT_ERROR => + + NULL ; + + WHEN OTHERS => + + FAILED( "WRONG EXCEPTION RAISED - SUBTEST 11" ); + + END ; + + + ------------------------------------------------------------------- + + -- (12) SLICED ONE-DIMENSIONAL ARRAY OBJECTS WHOSE TYPEMARKS + -- WERE DEFINED USING THE "BOX" SYMBOL + -- AND FOR WHICH THE COMPONENT TYPE IS NOT 'CHARACTER' . + -- ((ONE-DIMENSIONAL) ARRAYS OF BOOLEANS.) + + DECLARE + + TYPE TABOX5 IS ARRAY( INTEGER RANGE <> ) OF BOOLEAN ; + + SUBTYPE TABOX51 IS TABOX5( 1..5 ); + + ARRX51 : TABOX51 ; + ARRX52 : TABOX5( 5..9 ); + + BEGIN + + -- INITIALIZATION OF RHS ARRAY: + + FOR I IN 1..5 LOOP + ARRX51( I ) := FALSE ; -- VALUES WILL BE: F T F F T + END LOOP; + + ARRX51(2) := TRUE ; + + ARRX51(5) := TRUE ; -- RHS VALUES ARE: F T F F T + + + -- INITIALIZATION OF LHS ARRAY: + + FOR I IN 5..9 LOOP + ARRX52( I ) := TRUE ; -- VALUES WILL BE: T F T T F + END LOOP; + + ARRX52(6) := FALSE ; + + ARRX52(9) := FALSE ; -- LHS VALUES ARE: T F T T F + + + -- NULL SLICE ASSIGNMENT: + + ARRX52( 6..5 ) := ARRX51( 4..4 ) ; + FAILED( "EXCEPTION NOT RAISED - SUBTEST 12" ); + + EXCEPTION + + WHEN CONSTRAINT_ERROR => + + -- CHECKING THE VALUES AFTER THE SLICE ASSIGNMENT: + IF ARRX52( 5 ) /= TRUE OR + ARRX52( 6 ) /= FALSE OR + ARRX52( 7 ) /= TRUE OR + ARRX52( 8 ) /= TRUE OR + ARRX52( 9 ) /= FALSE + THEN + FAILED( "LHS ARRAY ALTERED (12)" ); + END IF; + + WHEN OTHERS => + + FAILED( "WRONG EXCEPTION RAISED - SUBTEST 12" ); + + END ; + + + ------------------------------------------------------------------- + + + RESULT ; + + +END C52104F; diff --git a/gcc/testsuite/ada/acats/tests/c5/c52104g.ada b/gcc/testsuite/ada/acats/tests/c5/c52104g.ada new file mode 100644 index 000000000..40f5daa99 --- /dev/null +++ b/gcc/testsuite/ada/acats/tests/c5/c52104g.ada @@ -0,0 +1,146 @@ +-- C52104G.ADA + +-- Grant of Unlimited Rights +-- +-- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687, +-- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained +-- unlimited rights in the software and documentation contained herein. +-- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making +-- this public release, the Government intends to confer upon all +-- recipients unlimited rights equal to those held by the Government. +-- These rights include rights to use, duplicate, release or disclose the +-- released technical data and computer software in whole or in part, in +-- any manner and for any purpose whatsoever, and to have or permit others +-- to do so. +-- +-- DISCLAIMER +-- +-- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR +-- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED +-- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF 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 LENGTHS MUST MATCH IN ARRAY AND SLICE ASSIGNMENTS. +-- MORE SPECIFICALLY, TEST THAT ATTEMPTED ASSIGNMENTS BETWEEN +-- ARRAYS WITH NON-MATCHING LENGTHS LEAVE THE DESTINATION ARRAY +-- INTACT AND CAUSE CONSTRAINT_ERROR TO BE RAISED. +-- (OVERLAPS BETWEEN THE OPERANDS OF THE ASSIGNMENT STATEMENT +-- ARE TREATED ELSEWHERE.) + +-- THIS IS THE SECOND FILE IN +-- DIVISION B : STATICALLY-DETERMINABLE NULL LENGTHS. + + +-- RM 07/20/81 +-- SPS 3/22/83 +-- JBG 4/24/84 + +WITH REPORT; +PROCEDURE C52104G IS + + USE REPORT ; + +BEGIN + + TEST( "C52104G" , "CHECK THAT IN ARRAY ASSIGNMENTS AND IN SLICE" & + " ASSIGNMENTS THE LENGTHS MUST MATCH" ); + + + -- ( EACH DIVISION COMPRISES 3 FILES, + -- COVERING RESPECTIVELY THE FIRST + -- 3 , NEXT 2 , AND LAST 3 OF THE 8 + -- SELECTIONS FOR THE DIVISION.) + + + ------------------------------------------------------------------- + + -- (13) UNSLICED ONE-DIMENSIONAL ARRAY OBJECTS WHOSE TYPEMARKS + -- WERE DEFINED USING THE "BOX" SYMBOL + -- AND FOR WHICH THE COMPONENT TYPE IS 'CHARACTER' . + + DECLARE + + TYPE TABOX3 IS ARRAY( NATURAL RANGE <> ) OF CHARACTER ; + + ARRX31 : TABOX3( 11..10 ) := "" ; + + BEGIN + + + -- ARRAY ASSIGNMENT (WITH STRING AGGREGATE): + + ARRX31 := "AZ" ; + FAILED( "EXCEPTION NOT RAISED - SUBTEST 13" ); + + EXCEPTION + + WHEN CONSTRAINT_ERROR => + + -- CHECKING THE VALUES AFTER THE SLICE ASSIGNMENT: + + IF ARRX31 /= "" + THEN + FAILED( "ARRAY ASSIGNMENT NOT CORRECT (13)" ); + END IF; + + WHEN OTHERS => + + FAILED( "WRONG EXCEPTION RAISED - SUBTEST 13" ); + + END ; + + + ------------------------------------------------------------------- + + -- (14) SLICED ONE-DIMENSIONAL ARRAY OBJECTS WHOSE TYPEMARKS + -- WERE DEFINED USING THE "BOX" SYMBOL + -- AND FOR WHICH THE COMPONENT TYPE IS 'CHARACTER' . + + DECLARE + + TYPE TABOX4 IS ARRAY( INTEGER RANGE <> ) OF CHARACTER ; + + SUBTYPE TABOX42 IS TABOX4( 11..15 ); + + ARRX42 : TABOX42 ; + + BEGIN + + -- INITIALIZATION OF LHS ARRAY: + + ARRX42 := "QUINC" ; + + + -- NULL SLICE ASSIGNMENT: + + ARRX42( 13..12 ) := "ABCD" ; + FAILED( "EXCEPTION NOT RAISED - SUBTEST 14" ); + + EXCEPTION + + WHEN CONSTRAINT_ERROR => + + -- CHECKING THE VALUES AFTER THE SLICE ASSIGNMENT: + + IF ARRX42 /= "QUINC" OR + ARRX42( 11..15 ) /= "QUINC" + THEN + FAILED( "LHS ARRAY ALTERED (14)" ); + END IF; + + WHEN OTHERS => + + FAILED( "WRONG EXCEPTION RAISED - SUBTEST 14" ); + + END ; + + + ------------------------------------------------------------------- + + + RESULT ; + + +END C52104G; diff --git a/gcc/testsuite/ada/acats/tests/c5/c52104h.ada b/gcc/testsuite/ada/acats/tests/c5/c52104h.ada new file mode 100644 index 000000000..8846bba24 --- /dev/null +++ b/gcc/testsuite/ada/acats/tests/c5/c52104h.ada @@ -0,0 +1,183 @@ +-- C52104H.ADA + +-- Grant of Unlimited Rights +-- +-- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687, +-- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained +-- unlimited rights in the software and documentation contained herein. +-- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making +-- this public release, the Government intends to confer upon all +-- recipients unlimited rights equal to those held by the Government. +-- These rights include rights to use, duplicate, release or disclose the +-- released technical data and computer software in whole or in part, in +-- any manner and for any purpose whatsoever, and to have or permit others +-- to do so. +-- +-- DISCLAIMER +-- +-- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR +-- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED +-- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF 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 LENGTHS MUST MATCH IN ARRAY AND SLICE ASSIGNMENTS. +-- MORE SPECIFICALLY, TEST THAT ATTEMPTED ASSIGNMENTS BETWEEN +-- ARRAYS WITH NON-MATCHING LENGTHS LEAVE THE DESTINATION ARRAY +-- INTACT AND CAUSE CONSTRAINT_ERROR TO BE RAISED. +-- (OVERLAPS BETWEEN THE OPERANDS OF THE ASSIGNMENT STATEMENT +-- ARE TREATED ELSEWHERE.) + +-- THIS IS THE THIRD FILE IN +-- DIVISION B : STATICALLY-DETERMINABLE NULL LENGTHS. + + +-- RM 07/20/81 +-- SPS 3/22/83 + +WITH REPORT; +PROCEDURE C52104H IS + + USE REPORT ; + +BEGIN + + TEST( "C52104H" , "CHECK THAT IN ARRAY ASSIGNMENTS AND IN SLICE" & + " ASSIGNMENTS THE LENGTHS MUST MATCH" ); + + + -- ( EACH DIVISION COMPRISES 3 FILES, + -- COVERING RESPECTIVELY THE FIRST + -- 3 , NEXT 2 , AND LAST 3 OF THE 8 + -- SELECTIONS FOR THE DIVISION.) + + + ------------------------------------------------------------------- + + -- (7) UNSLICED OBJECTS OF THE PREDEFINED TYPE 'STRING' (BY + -- THEMSELVES). + + DECLARE + + ARR71 : STRING( 1..1 ) := "A" ; + ARR72 : STRING( 5..4 ) := "" ; + + BEGIN + + -- STRING ASSIGNMENT: + + ARR72 := ARR71 ; + FAILED( "EXCEPTION NOT RAISED - SUBTEST 7" ); + + EXCEPTION + + WHEN CONSTRAINT_ERROR => + + -- CHECKING THE VALUES AFTER THE STRING ASSIGNMENT: + + IF ARR72 /= "" + THEN + FAILED( "ORIGINAL VALUE ALTERED (7)" ); + END IF; + + WHEN OTHERS => + FAILED( "WRONG EXCEPTION RAISED - SUBTEST 7" ); + + END ; + + + ------------------------------------------------------------------- + + -- (8) SLICED OBJECTS OF THE PREDEFINED TYPE 'STRING' , WITH + -- STRING LITERALS. + -- + + DECLARE + + ARR82 : STRING( 5..9 ) ; + + BEGIN + + + -- INITIALIZATION OF LHS ARRAY: + + ARR82( 5..9 ) := "QUINC" ; + + + -- STRING LITERAL ASSIGNMENT: + + ARR82( 5..9 )( 6..9 )( 6..5 ) := "ABC" ; + FAILED( "EXCEPTION NOT RAISED - SUBTEST 8" ); + + EXCEPTION + + WHEN CONSTRAINT_ERROR => + + -- CHECKING THE VALUES AFTER THE STRING ASSIGNMENT: + + IF ARR82 /= "QUINC" OR + ARR82( 5..9 ) /= "QUINC" + THEN + FAILED( "ORIGINAL VALUE ALTERED (8)" ); + END IF; + + WHEN OTHERS => + + FAILED( "WRONG EXCEPTION RAISED - SUBTEST 8" ); + + END ; + + + ------------------------------------------------------------------- + + -- (9) SLICED OBJECTS OF THE PREDEFINED TYPE 'STRING' (BY + -- THEMSELVES). + -- + + DECLARE + + SUBTYPE TA92 IS STRING( 5..9 ) ; + + ARR91 : STRING( 1..5 ) := "ABCDE" ; + ARR92 : TA92 ; + + BEGIN + + + -- INITIALIZATION OF LHS ARRAY: + + ARR92( 5..9 ) := "QUINC" ; + + + -- STRING SLICE ASSIGNMENT: + + ARR92( 5..9 )( 6..9 )( 8..7 ) := ARR91( 1..5 )( 5..7 ) ; + FAILED( "EXCEPTION NOT RAISED - SUBTEST 9" ); + + EXCEPTION + + WHEN CONSTRAINT_ERROR => + + -- CHECKING THE VALUES AFTER THE STRING ASSIGNMENT: + + IF ARR92 /= "QUINC" OR + ARR92( 5..9 ) /= "QUINC" + THEN + FAILED( "ORIGINAL VALUE ALTERED (9)" ); + END IF; + + WHEN OTHERS => + + FAILED( "WRONG EXCEPTION RAISED - SUBTEST 9" ); + + END ; + + + ------------------------------------------------------------------- + + + RESULT ; + + +END C52104H; diff --git a/gcc/testsuite/ada/acats/tests/c5/c52104k.ada b/gcc/testsuite/ada/acats/tests/c5/c52104k.ada new file mode 100644 index 000000000..f7abc7367 --- /dev/null +++ b/gcc/testsuite/ada/acats/tests/c5/c52104k.ada @@ -0,0 +1,347 @@ +-- C52104K.ADA + +-- Grant of Unlimited Rights +-- +-- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687, +-- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained +-- unlimited rights in the software and documentation contained herein. +-- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making +-- this public release, the Government intends to confer upon all +-- recipients unlimited rights equal to those held by the Government. +-- These rights include rights to use, duplicate, release or disclose the +-- released technical data and computer software in whole or in part, in +-- any manner and for any purpose whatsoever, and to have or permit others +-- to do so. +-- +-- DISCLAIMER +-- +-- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR +-- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED +-- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF 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 LENGTHS MUST MATCH IN ARRAY AND SLICE ASSIGNMENTS. +-- MORE SPECIFICALLY, TEST THAT ATTEMPTED ASSIGNMENTS BETWEEN +-- ARRAYS WITH NON-MATCHING LENGTHS LEAVE THE DESTINATION ARRAY +-- INTACT AND CAUSE CONSTRAINT_ERROR TO BE RAISED. +-- (OVERLAPS BETWEEN THE OPERANDS OF THE ASSIGNMENT STATEMENT +-- ARE TREATED ELSEWHERE.) + +-- DIVISION C : NON-NULL LENGTHS NOT DETERMINABLE STATICALLY. + + +-- RM 07/20/81 +-- SPS 3/22/83 + +WITH REPORT; +PROCEDURE C52104K IS + + USE REPORT ; + +BEGIN + + TEST( "C52104K" , "CHECK THAT IN ARRAY ASSIGNMENTS AND IN SLICE" & + " ASSIGNMENTS THE LENGTHS MUST MATCH" ); + + + -- IN THIS TEST WE CAN'T USE AGGREGATE ASSIGNMENT (EXCEPT WHEN + -- THE AGGREGATES ARE STRING LITERALS); THEREFORE: + -- + -- (1) ARRAYS WILL BE INITIALIZED BY INDIVIDUAL ASSIGNMENTS; + -- (2) CAN'T USE NON-NULL CONSTANT ARRAYS. + + + -- WE ASSUME THAT IN AN ARRAY_TYPE_DEFINITION THE INDEX PORTION + -- AND THE COMPONENT_TYPE PORTION ARE FUNCTIONALLY ORTHOGONAL + -- ALSO AT THE IMPLEMENTATION LEVEL, I.E. THAT THE CORRECTNESS + -- OF THE ACCESSING MECHANISM FOR ARRAYS DOES NOT DEPEND ON + -- COMPONENT_TYPE. ACCORDINGLY WE ARE TESTING FOR SOME BUT + -- NOT ALL KINDS OF COMPONENT_TYPE. (COMPONENT_TYPES INCLUDED: + -- INTEGER , CHARACTER , BOOLEAN .) + + + -- CASES DISTINGUISHED: ( 8 SELECTED CASES ARE IMPLEMENTED) + -- + -- ( THE 8 SELECTIONS ARE THE 5-CASE + -- SERIES 10-11-12-13-14 FOLLOWED + -- BY 7 , 8 , 9 (IN THIS ORDER). ) + -- + -- + -- ( EACH DIVISION COMPRISES 3 FILES, + -- COVERING RESPECTIVELY THE FIRST + -- 3 , NEXT 2 , AND LAST 3 OF THE 8 + -- SELECTIONS FOR THE DIVISION.) + -- + -- + -- (1..6) (DO NOT APPLY TO NON-MATCHING OBJECTS, SINCE WE WANT + -- THE OBJECTS TO HAVE THE S A M E BASE TYPE.) + -- + -- + -- (7) UNSLICED OBJECTS OF THE PREDEFINED TYPE 'STRING' (BY + -- THEMSELVES). + -- + -- + -- (8) SLICED OBJECTS OF THE PREDEFINED TYPE 'STRING' , WITH + -- STRING LITERALS. + -- + -- + -- (9) SLICED OBJECTS OF THE PREDEFINED TYPE 'STRING' (BY + -- THEMSELVES). + -- + -- + -- (-) CONSTRAINABLE TYPES: ONLY SUBTESTS 2, 3, 4, 5, 6 + -- WILL BE REPLICATED -- AS SUBTESTS 10, 11, 12, 13, 14 . + -- + -- + -- (10) MULTIDIMENSIONAL ARRAY OBJECTS WHOSE TYPEMARKS WERE + -- DEFINED USING THE "BOX" COMPOUND SYMBOL. + -- (TWO-DIMENSIONAL ARRAYS OF INTEGERS.) + -- + -- + -- (11) UNSLICED ONE-DIMENSIONAL ARRAY OBJECTS WHOSE TYPEMARKS + -- WERE DEFINED USING THE "BOX" SYMBOL + -- AND FOR WHICH THE COMPONENT TYPE IS NOT 'CHARACTER' . + -- ((ONE-DIMENSIONAL) ARRAYS OF INTEGERS.) + -- + -- + -- (12) SLICED ONE-DIMENSIONAL ARRAY OBJECTS WHOSE TYPEMARKS + -- WERE DEFINED USING THE "BOX" SYMBOL + -- AND FOR WHICH THE COMPONENT TYPE IS NOT 'CHARACTER' . + -- ((ONE-DIMENSIONAL) ARRAYS OF BOOLEANS.) + -- + -- + -- (13) UNSLICED ONE-DIMENSIONAL ARRAY OBJECTS WHOSE TYPEMARKS + -- WERE DEFINED USING THE "BOX" SYMBOL + -- AND FOR WHICH THE COMPONENT TYPE IS 'CHARACTER' . + -- + -- (STRING LITERALS ARE THE ONLY AGGREGATES WE ARE USING + -- IN THIS TEST. TO FORCE SLIDING, THE LOWER LIMIT IMPLIED + -- BY THE TYPEMARK WILL NOT BE 1 .) + -- + -- + -- (14) SLICED ONE-DIMENSIONAL ARRAY OBJECTS WHOSE TYPEMARKS + -- WERE DEFINED USING THE "BOX" SYMBOL + -- AND FOR WHICH THE COMPONENT TYPE IS 'CHARACTER' . + -- + -- + -- + -- (-) SPECIAL CASES: NULL ARRAYS....... TREATED IN DIVISION B. + -- SUPERLONG ARRAYS.. (TREATED FOR DYNAMIC + -- ARRAYS ONLY, + -- DIVISIONS C AND D .) + -- + -- + -- (-) THE STATIC-ARRAY COUNTERPARTS OF THESE TESTS ARE IN DI- + -- VISIONS A (FOR NON-NULL ARRAYS) AND B (FOR NULL ARRAYS). + -- + -- + + + ------------------------------------------------------------------- + + -- (1..6: NOT APPLICABLE) + -- + -- + + ------------------------------------------------------------------- + + -- (10) MULTIDIMENSIONAL ARRAY OBJECTS WHOSE TYPEMARKS WERE + -- DEFINED USING THE "BOX" COMPOUND SYMBOL. + -- (TWO-DIMENSIONAL ARRAYS OF INTEGERS.) + + DECLARE + + TYPE TABOX0 IS ARRAY( INTEGER RANGE <> , INTEGER RANGE <> + ) OF INTEGER ; + + SUBTYPE TABOX01 IS TABOX0( IDENT_INT(1)..IDENT_INT(5) , + IDENT_INT(0)..IDENT_INT(7) ); + SUBTYPE TABOX02 IS TABOX0( IDENT_INT(0)..IDENT_INT(5) , + IDENT_INT(2)..IDENT_INT(9) ); + + ARRX01 : TABOX01 ; + ARRX02 : TABOX02 ; + + BEGIN + + -- INITIALIZATION OF RHS ARRAY: + + FOR I IN IDENT_INT(1)..IDENT_INT(5) LOOP + + FOR J IN IDENT_INT(0)..IDENT_INT(7) LOOP + ARRX01( I , J ) := I * I * J ; + END LOOP; + + END LOOP; + + + -- INITIALIZATION OF LHS ARRAY: + + FOR I IN IDENT_INT(0)..IDENT_INT(5) LOOP + + FOR J IN IDENT_INT(2)..IDENT_INT(9) LOOP + ARRX02( I , J ) := I * I * J * 3 ; + END LOOP; + + END LOOP; + + + -- ARRAY ASSIGNMENT: + + ARRX02 := ARRX01 ; + FAILED( "EXCEPTION NOT RAISED - SUBTEST 10" ); + + EXCEPTION + + WHEN CONSTRAINT_ERROR => + + -- CHECKING THE VALUES AFTER THE ARRAY ASSIGNMENT: + + FOR I IN IDENT_INT(0)..IDENT_INT(5) LOOP + + FOR J IN IDENT_INT(2)..IDENT_INT(9) LOOP + + IF ARRX02( I , J ) /= I * I * J * 3 + THEN + FAILED( "ORIG. VALUE ALTERED (10)" ); + END IF; + + END LOOP; + + END LOOP; + + WHEN OTHERS => + FAILED( "WRONG EXCEPTION RAISED - SUBTEST 10" ); + + END ; + + + ------------------------------------------------------------------- + + -- (11) UNSLICED ONE-DIMENSIONAL ARRAY OBJECTS WHOSE TYPEMARKS + -- WERE DEFINED USING THE "BOX" SYMBOL + -- AND FOR WHICH THE COMPONENT TYPE IS NOT 'CHARACTER' . + -- ((ONE-DIMENSIONAL) ARRAYS OF INTEGERS.) + + DECLARE + + TYPE TABOX1 IS ARRAY( INTEGER RANGE <> ) OF INTEGER ; + + SUBTYPE TABOX11 IS TABOX1( IDENT_INT(1)..IDENT_INT(5) ) ; + + ARRX11 : TABOX11 ; + ARRX12 : TABOX1( IDENT_INT(6)..IDENT_INT(9) ); + + BEGIN + + -- INITIALIZATION OF RHS ARRAY: + + FOR I IN IDENT_INT(1)..IDENT_INT(5) LOOP + + ARRX11( I ) := I * I ; + + END LOOP; + + + -- INITIALIZATION OF LHS ARRAY: + + FOR I IN IDENT_INT(6)..IDENT_INT(9) LOOP + ARRX12( I ) := I * I * 3 ; + END LOOP; + + + -- ARRAY ASSIGNMENT: + + ARRX12 := ARRX11 ; + FAILED( "EXCEPTION NOT RAISED - SUBTEST 11" ); + + EXCEPTION + + WHEN CONSTRAINT_ERROR => + + -- CHECKING THE VALUES AFTER THE ARRAY ASSIGNMENT: + + FOR I IN IDENT_INT(6)..IDENT_INT(9) LOOP + + IF ARRX12( I ) /= I * I * 3 + THEN + FAILED( "ORIG. VALUE ALTERED (11)" ); + END IF; + + END LOOP; + + WHEN OTHERS => + FAILED( "WRONG EXCEPTION RAISED - SUBTEST 11" ); + + END ; + + + ------------------------------------------------------------------- + + -- (12) SLICED ONE-DIMENSIONAL ARRAY OBJECTS WHOSE TYPEMARKS + -- WERE DEFINED USING THE "BOX" SYMBOL + -- AND FOR WHICH THE COMPONENT TYPE IS NOT 'CHARACTER' . + -- ((ONE-DIMENSIONAL) ARRAYS OF BOOLEANS.) + + DECLARE + + TYPE TABOX5 IS ARRAY( INTEGER RANGE <> ) OF BOOLEAN ; + + SUBTYPE TABOX51 IS TABOX5( IDENT_INT(1)..IDENT_INT(5) ); + + ARRX51 : TABOX51 ; + ARRX52 : TABOX5( IDENT_INT(5)..IDENT_INT(9) ); + + BEGIN + + -- INITIALIZATION OF LHS ARRAY: + + FOR I IN IDENT_INT(5)..IDENT_INT(9) LOOP + ARRX52( I ) := FALSE ; + END LOOP; + + + -- INITIALIZATION OF RHS ARRAY: + + FOR I IN IDENT_INT(1)..IDENT_INT(5) LOOP + ARRX51( I ) := TRUE ; + END LOOP; + + + -- SLICE ASSIGNMENT: + + ARRX52( IDENT_INT(6)..IDENT_INT(9) ) := + ARRX51( + IDENT_INT(3)..IDENT_INT(3) ) ; + FAILED( "EXCEPTION NOT RAISED (12)" ); + + EXCEPTION + + WHEN CONSTRAINT_ERROR => + + -- CHECKING THE VALUES AFTER THE SLICE ASSIGNMENT: + + FOR I IN IDENT_INT(5)..IDENT_INT(9) LOOP + + IF ARRX52( I ) /= FALSE + THEN + FAILED( "LHS ARRAY ALTERED ( 12 ) " ); + END IF; + + END LOOP; + + WHEN OTHERS => + FAILED( "EXCEPTION RAISED - SUBTEST 12" ); + + END ; + + + ------------------------------------------------------------------- + + + RESULT ; + + +END C52104K; diff --git a/gcc/testsuite/ada/acats/tests/c5/c52104l.ada b/gcc/testsuite/ada/acats/tests/c5/c52104l.ada new file mode 100644 index 000000000..ca7ae3271 --- /dev/null +++ b/gcc/testsuite/ada/acats/tests/c5/c52104l.ada @@ -0,0 +1,146 @@ +-- C52104L.ADA + +-- Grant of Unlimited Rights +-- +-- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687, +-- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained +-- unlimited rights in the software and documentation contained herein. +-- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making +-- this public release, the Government intends to confer upon all +-- recipients unlimited rights equal to those held by the Government. +-- These rights include rights to use, duplicate, release or disclose the +-- released technical data and computer software in whole or in part, in +-- any manner and for any purpose whatsoever, and to have or permit others +-- to do so. +-- +-- DISCLAIMER +-- +-- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR +-- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED +-- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF 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 LENGTHS MUST MATCH IN ARRAY AND SLICE ASSIGNMENTS. +-- MORE SPECIFICALLY, TEST THAT ATTEMPTED ASSIGNMENTS BETWEEN +-- ARRAYS WITH NON-MATCHING LENGTHS LEAVE THE DESTINATION ARRAY +-- INTACT AND CAUSE CONSTRAINT_ERROR TO BE RAISED. +-- (OVERLAPS BETWEEN THE OPERANDS OF THE ASSIGNMENT STATEMENT +-- ARE TREATED ELSEWHERE.) + +-- THIS IS THE SECOND FILE IN +-- DIVISION C : NON-NULL LENGTHS NOT DETERMINABLE STATICALLY. + +-- HISTORY: +-- RM 07/20/81 CREATED ORIGINAL TEST. +-- SPS 03/22/83 +-- DHH 10/20/87 SHORTENED LINES CONTAINING MORE THAN 72 CHARACTERS. + +WITH REPORT; +PROCEDURE C52104L IS + + USE REPORT ; + +BEGIN + + TEST( "C52104L" , "CHECK THAT IN ARRAY ASSIGNMENTS AND IN SLICE" & + " ASSIGNMENTS THE LENGTHS MUST MATCH" ); + + + -- ( EACH DIVISION COMPRISES 3 FILES, + -- COVERING RESPECTIVELY THE FIRST + -- 3 , NEXT 2 , AND LAST 3 OF THE 8 + -- SELECTIONS FOR THE DIVISION.) + + + ------------------------------------------------------------------- + + -- (13) UNSLICED ONE-DIMENSIONAL ARRAY OBJECTS WHOSE TYPEMARKS + -- WERE DEFINED USING THE "BOX" SYMBOL + -- AND FOR WHICH THE COMPONENT TYPE IS 'CHARACTER' . + + DECLARE + + TYPE TABOX3 IS ARRAY( INTEGER RANGE <> ) OF CHARACTER ; + + ARRX31 : TABOX3( IDENT_INT(2)..IDENT_INT(6) ) := "QUINC" ; + + BEGIN + + + -- ARRAY ASSIGNMENT (WITH STRING AGGREGATE): + + ARRX31 := "ABCD" ; + FAILED( "NO EXCEPTION RAISED (13)" ); + + EXCEPTION + + WHEN CONSTRAINT_ERROR => + + -- CHECKING THE VALUES AFTER THE ASSIGNMENT: + + IF ARRX31 /= "QUINC" OR + ARRX31( IDENT_INT(2)..IDENT_INT(6) ) /= "QUINC" + THEN + FAILED( "LHS ARRAY ALTERED (13)" ); + END IF; + + WHEN OTHERS => + FAILED( "WRONG EXCEPTION RAISED - SUBTEST 13" ); + + END ; + + + ------------------------------------------------------------------- + + -- (14) SLICED ONE-DIMENSIONAL ARRAY OBJECTS WHOSE TYPEMARKS + -- WERE DEFINED USING THE "BOX" SYMBOL + -- AND FOR WHICH THE COMPONENT TYPE IS 'CHARACTER' . + + DECLARE + + TYPE TABOX4 IS ARRAY( INTEGER RANGE <> ) OF CHARACTER ; + + SUBTYPE TABOX42 IS TABOX4( IDENT_INT(5)..IDENT_INT(9) ); + + ARRX42 : TABOX42 ; + + BEGIN + + -- INITIALIZATION OF LHS ARRAY: + + ARRX42 := "QUINC" ; + + + -- SLICE ASSIGNMENT: + + ARRX42( IDENT_INT(6)..IDENT_INT(9) ) := "ABCDEFGH" ; + FAILED( "NO EXCEPTION RAISED (14)" ); + + EXCEPTION + + WHEN CONSTRAINT_ERROR => + + -- CHECKING THE VALUES AFTER THE ASSIGNMENT: + + IF ARRX42 /= "QUINC" OR + ARRX42( IDENT_INT(5)..IDENT_INT(9) ) /= "QUINC" + THEN + FAILED( "LHS ARRAY ALTERED (14)" ); + END IF; + + WHEN OTHERS => + FAILED( "WRONG EXCEPTION RAISED - SUBTEST 14" ); + + END ; + + + ------------------------------------------------------------------- + + + RESULT ; + + +END C52104L; diff --git a/gcc/testsuite/ada/acats/tests/c5/c52104m.ada b/gcc/testsuite/ada/acats/tests/c5/c52104m.ada new file mode 100644 index 000000000..3227d591d --- /dev/null +++ b/gcc/testsuite/ada/acats/tests/c5/c52104m.ada @@ -0,0 +1,184 @@ +-- C52104M.ADA + +-- Grant of Unlimited Rights +-- +-- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687, +-- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained +-- unlimited rights in the software and documentation contained herein. +-- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making +-- this public release, the Government intends to confer upon all +-- recipients unlimited rights equal to those held by the Government. +-- These rights include rights to use, duplicate, release or disclose the +-- released technical data and computer software in whole or in part, in +-- any manner and for any purpose whatsoever, and to have or permit others +-- to do so. +-- +-- DISCLAIMER +-- +-- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR +-- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED +-- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF 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 LENGTHS MUST MATCH IN ARRAY AND SLICE ASSIGNMENTS. +-- MORE SPECIFICALLY, TEST THAT ATTEMPTED ASSIGNMENTS BETWEEN +-- ARRAYS WITH NON-MATCHING LENGTHS LEAVE THE DESTINATION ARRAY +-- INTACT AND CAUSE CONSTRAINT_ERROR TO BE RAISED. +-- (OVERLAPS BETWEEN THE OPERANDS OF THE ASSIGNMENT STATEMENT +-- ARE TREATED ELSEWHERE.) + +-- THIS IS THE THIRD FILE IN +-- DIVISION C : NON-NULL LENGTHS NOT DETERMINABLE STATICALLY. + + +-- RM 07/20/81 +-- SPS 3/22/83 + +WITH REPORT; +PROCEDURE C52104M IS + + USE REPORT ; + +BEGIN + + TEST( "C52104M" , "CHECK THAT IN ARRAY ASSIGNMENTS AND IN SLICE" & + " ASSIGNMENTS THE LENGTHS MUST MATCH" ); + + + -- ( EACH DIVISION COMPRISES 3 FILES, + -- COVERING RESPECTIVELY THE FIRST + -- 3 , NEXT 2 , AND LAST 3 OF THE 8 + -- SELECTIONS FOR THE DIVISION.) + + + ------------------------------------------------------------------- + + -- (7) UNSLICED OBJECTS OF THE PREDEFINED TYPE 'STRING' (BY + -- THEMSELVES). + + DECLARE + + ARR71 : STRING( IDENT_INT(1)..IDENT_INT(5) ) := "ABCDE" ; + ARR72 : STRING( IDENT_INT(5)..IDENT_INT(8) ) := "FGHI" ; + + BEGIN + + + -- STRING ASSIGNMENT: + + ARR72 := ARR71 ; + FAILED( "EXCEPTION NOT RAISED - SUBTEST 7" ); + + EXCEPTION + + WHEN CONSTRAINT_ERROR => + + -- CHECKING THE VALUES AFTER THE STRING ASSIGNMENT: + + IF ARR72 /= "FGHI" + THEN + FAILED( "ORIGINAL VALUE ALTERED (7)" ); + END IF; + + WHEN OTHERS => + FAILED( "WRONG EXCEPTION RAISED - SUBTEST 7" ); + + END ; + + + ------------------------------------------------------------------- + + + -- (8) SLICED OBJECTS OF THE PREDEFINED TYPE 'STRING' , WITH + -- STRING LITERALS. + -- + + DECLARE + + ARR82 : STRING( IDENT_INT(5)..IDENT_INT(9) ) := "QBCDE" ; + + BEGIN + + + -- STRING LITERAL ASSIGNMENT: + + ARR82( IDENT_INT(5)..IDENT_INT(9) ) + ( IDENT_INT(6)..IDENT_INT(9) ) := "EIN" ; + FAILED( "EXCEPTION NOT RAISED - SUBTEST 8" ); + + EXCEPTION + + WHEN CONSTRAINT_ERROR => + + -- CHECKING THE VALUES AFTER THE SLICE ASSIGNMENT: + + IF ARR82 /= "QBCDE" OR + ARR82( IDENT_INT(5)..IDENT_INT(9) ) /= "QBCDE" + THEN + FAILED( "LHS ARRAY ALTERED (8)" ); + END IF; + + WHEN OTHERS => + FAILED( "WRONG EXCEPTION RAISED - SUBTEST 8" ); + + END ; + + + ------------------------------------------------------------------- + + -- (9) SLICED OBJECTS OF THE PREDEFINED TYPE 'STRING' (BY + -- THEMSELVES). + -- + + DECLARE + + SUBTYPE TA92 IS STRING( IDENT_INT(5)..IDENT_INT(9) ) ; + + ARR91 : STRING( IDENT_INT(1)..IDENT_INT(7) ) := "ABCDEFG" ; + ARR92 : TA92 ; + + BEGIN + + + -- INITIALIZATION OF LHS ARRAY: + + ARR92( IDENT_INT(5)..IDENT_INT(9) ) := "QUINC" ; + + + -- STRING SLICE ASSIGNMENT: + + ARR92( IDENT_INT(5)..IDENT_INT(9) ) + ( IDENT_INT(6)..IDENT_INT(9) ) := + ARR91 + ( IDENT_INT(1)..IDENT_INT(7) ) + ( IDENT_INT(1)..IDENT_INT(6) ) + ( IDENT_INT(1)..IDENT_INT(6) ) ; + FAILED( "EXCEPTION NOT RAISED - SUBTEST 9" ); + + EXCEPTION + + WHEN CONSTRAINT_ERROR => + + -- CHECKING THE VALUES AFTER THE SLICE ASSIGNMENT: + + IF ARR92 /= "QUINC" OR + ARR92( IDENT_INT(5)..IDENT_INT(9) ) /= "QUINC" + THEN + FAILED( "LHS VALUE ALTERED (9)" ); + END IF; + + WHEN OTHERS => + FAILED( "WRONG EXCEPTION RAISED - SUBTEST 9" ); + + END ; + + + ------------------------------------------------------------------- + + + RESULT ; + + +END C52104M; diff --git a/gcc/testsuite/ada/acats/tests/c5/c52104p.ada b/gcc/testsuite/ada/acats/tests/c5/c52104p.ada new file mode 100644 index 000000000..f455519a0 --- /dev/null +++ b/gcc/testsuite/ada/acats/tests/c5/c52104p.ada @@ -0,0 +1,292 @@ +-- C52104P.ADA + +-- Grant of Unlimited Rights +-- +-- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687, +-- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained +-- unlimited rights in the software and documentation contained herein. +-- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making +-- this public release, the Government intends to confer upon all +-- recipients unlimited rights equal to those held by the Government. +-- These rights include rights to use, duplicate, release or disclose the +-- released technical data and computer software in whole or in part, in +-- any manner and for any purpose whatsoever, and to have or permit others +-- to do so. +-- +-- DISCLAIMER +-- +-- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR +-- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED +-- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF 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 LENGTHS MUST MATCH IN ARRAY AND SLICE ASSIGNMENTS. +-- MORE SPECIFICALLY, TEST THAT ATTEMPTED ASSIGNMENTS BETWEEN +-- ARRAYS WITH NON-MATCHING LENGTHS LEAVE THE DESTINATION ARRAY +-- INTACT AND CAUSE CONSTRAINT_ERROR TO BE RAISED. +-- (OVERLAPS BETWEEN THE OPERANDS OF THE ASSIGNMENT STATEMENT +-- ARE TREATED ELSEWHERE.) + +-- DIVISION D : NULL LENGTHS NOT DETERMINABLE STATICALLY. + + +-- RM 07/20/81 + + +WITH REPORT; +PROCEDURE C52104P IS + + USE REPORT ; + +BEGIN + + TEST( "C52104P" , "CHECK THAT IN ARRAY ASSIGNMENTS AND IN SLICE" & + " ASSIGNMENTS THE LENGTHS MUST MATCH" ); + + + -- IN THIS TEST WE CAN'T USE AGGREGATE ASSIGNMENT (EXCEPT WHEN + -- THE AGGREGATES ARE STRING LITERALS); THEREFORE: + -- + -- (1) ARRAYS WILL BE INITIALIZED BY INDIVIDUAL ASSIGNMENTS; + -- (2) CAN'T USE NON-NULL CONSTANT ARRAYS. + + + -- WE ASSUME THAT IN AN ARRAY_TYPE_DEFINITION THE INDEX PORTION + -- AND THE COMPONENT_TYPE PORTION ARE FUNCTIONALLY ORTHOGONAL + -- ALSO AT THE IMPLEMENTATION LEVEL, I.E. THAT THE CORRECTNESS + -- OF THE ACCESSING MECHANISM FOR ARRAYS DOES NOT DEPEND ON + -- COMPONENT_TYPE. ACCORDINGLY WE ARE TESTING FOR SOME BUT + -- NOT ALL KINDS OF COMPONENT_TYPE. (COMPONENT_TYPES INCLUDED: + -- INTEGER , CHARACTER , BOOLEAN .) + + + -- CASES DISTINGUISHED: ( 8 SELECTED CASES ARE IMPLEMENTED) + -- + -- ( THE 8 SELECTIONS ARE THE 5-CASE + -- SERIES 10-11-12-13-14 FOLLOWED + -- BY 7 , 8 , 9 (IN THIS ORDER). ) + -- + -- + -- ( EACH DIVISION COMPRISES 3 FILES, + -- COVERING RESPECTIVELY THE FIRST + -- 3 , NEXT 2 , AND LAST 3 OF THE 8 + -- SELECTIONS FOR THE DIVISION.) + -- + -- + -- (1..6) (DO NOT APPLY TO NON-MATCHING OBJECTS, SINCE WE WANT + -- THE OBJECTS TO HAVE THE S A M E BASE TYPE.) + -- + -- + -- (7) UNSLICED OBJECTS OF THE PREDEFINED TYPE 'STRING' (BY + -- THEMSELVES). + -- + -- + -- (8) SLICED OBJECTS OF THE PREDEFINED TYPE 'STRING' , WITH + -- STRING LITERALS. + -- + -- + -- (9) SLICED OBJECTS OF THE PREDEFINED TYPE 'STRING' (BY + -- THEMSELVES). + -- + -- + -- (-) CONSTRAINABLE TYPES: ONLY SUBTESTS 2, 3, 4, 5, 6 + -- WILL BE REPLICATED -- AS SUBTESTS 10, 11, 12, 13, 14 . + -- + -- + -- (10) MULTIDIMENSIONAL ARRAY OBJECTS WHOSE TYPEMARKS WERE + -- DEFINED USING THE "BOX" COMPOUND SYMBOL. + -- (TWO-DIMENSIONAL ARRAYS OF INTEGERS.) + -- + -- + -- (11) UNSLICED ONE-DIMENSIONAL ARRAY OBJECTS WHOSE TYPEMARKS + -- WERE DEFINED USING THE "BOX" SYMBOL + -- AND FOR WHICH THE COMPONENT TYPE IS NOT 'CHARACTER' . + -- ((ONE-DIMENSIONAL) ARRAYS OF INTEGERS.) + -- + -- + -- (12) SLICED ONE-DIMENSIONAL ARRAY OBJECTS WHOSE TYPEMARKS + -- WERE DEFINED USING THE "BOX" SYMBOL + -- AND FOR WHICH THE COMPONENT TYPE IS NOT 'CHARACTER' . + -- ((ONE-DIMENSIONAL) ARRAYS OF BOOLEANS.) + -- + -- + -- (13) UNSLICED ONE-DIMENSIONAL ARRAY OBJECTS WHOSE TYPEMARKS + -- WERE DEFINED USING THE "BOX" SYMBOL + -- AND FOR WHICH THE COMPONENT TYPE IS 'CHARACTER' . + -- + -- (STRING LITERALS ARE THE ONLY AGGREGATES WE ARE USING + -- IN THIS TEST. TO FORCE SLIDING, THE LOWER LIMIT IMPLIED + -- BY THE TYPEMARK WILL NOT BE 1 .) + -- + -- + -- (14) SLICED ONE-DIMENSIONAL ARRAY OBJECTS WHOSE TYPEMARKS + -- WERE DEFINED USING THE "BOX" SYMBOL + -- AND FOR WHICH THE COMPONENT TYPE IS 'CHARACTER' . + -- + -- + -- + -- (-) SPECIAL CASES: SUPERLONG ARRAYS.. (TREATED FOR DYNAMIC + -- ARRAYS ONLY, + -- DIVISIONS C AND D .) + -- + -- + + + ------------------------------------------------------------------- + + -- (1 .. 6: NOT APPLICABLE) + -- + -- + + ------------------------------------------------------------------- + + -- (10) MULTIDIMENSIONAL ARRAY OBJECTS WHOSE TYPEMARKS WERE + -- DEFINED USING THE "BOX" COMPOUND SYMBOL. + -- (TWO-DIMENSIONAL ARRAYS OF INTEGERS.) + + DECLARE + + TYPE TABOX0 IS ARRAY( INTEGER RANGE <> , INTEGER RANGE <> + ) OF INTEGER ; + + SUBTYPE TABOX01 IS TABOX0( IDENT_INT(1)..IDENT_INT(1) , + IDENT_INT(0)..IDENT_INT(7) ); + SUBTYPE TABOX02 IS TABOX0 ; + + ARRX01 : TABOX01 ; + ARRX02 : TABOX02( IDENT_INT(1)..IDENT_INT(0) , + IDENT_INT(0)..IDENT_INT(7) ); + + BEGIN + + -- ARRAY ASSIGNMENT: + + ARRX02 := ARRX01 ; + FAILED( "EXCEPTION NOT RAISED - SUBTEST 10" ); + + EXCEPTION + + WHEN CONSTRAINT_ERROR => + + NULL ; + + WHEN OTHERS => + + FAILED( "WRONG EXCEPTION RAISED - SUBTEST 10" ); + + END ; + + + ------------------------------------------------------------------- + + -- (11) UNSLICED ONE-DIMENSIONAL ARRAY OBJECTS WHOSE TYPEMARKS + -- WERE DEFINED USING THE "BOX" SYMBOL + -- AND FOR WHICH THE COMPONENT TYPE IS NOT 'CHARACTER' . + -- ((ONE-DIMENSIONAL) ARRAYS OF INTEGERS.) + + DECLARE + + TYPE TABOX1 IS ARRAY( INTEGER RANGE <> ) OF INTEGER ; + + SUBTYPE TABOX11 IS TABOX1( IDENT_INT(4)..IDENT_INT(5) ) ; + + ARRX11 : TABOX11 ; + ARRX12 : TABOX1( IDENT_INT(5)..IDENT_INT(4) ); + + BEGIN + + -- ARRAY ASSIGNMENT: + + ARRX12 := ARRX11 ; + FAILED( "EXCEPTION NOT RAISED - SUBTEST 11" ); + + EXCEPTION + + WHEN CONSTRAINT_ERROR => + + NULL ; + + WHEN OTHERS => + + FAILED( "WRONG EXCEPTION RAISED - SUBTEST 11" ); + + END ; + + + ------------------------------------------------------------------- + + -- (12) SLICED ONE-DIMENSIONAL ARRAY OBJECTS WHOSE TYPEMARKS + -- WERE DEFINED USING THE "BOX" SYMBOL + -- AND FOR WHICH THE COMPONENT TYPE IS NOT 'CHARACTER' . + -- ((ONE-DIMENSIONAL) ARRAYS OF BOOLEANS.) + + DECLARE + + TYPE TABOX5 IS ARRAY( INTEGER RANGE <> ) OF BOOLEAN ; + + SUBTYPE TABOX51 IS TABOX5( IDENT_INT(1)..IDENT_INT(5) ); + + ARRX51 : TABOX51 ; + ARRX52 : TABOX5( IDENT_INT(5)..IDENT_INT(9) ); + + BEGIN + + -- INITIALIZATION OF RHS ARRAY: + + FOR I IN IDENT_INT(1)..IDENT_INT(5) LOOP + ARRX51( I ) := FALSE ; -- VALUES WILL BE: F T F F T + END LOOP; + + ARRX51(2) := TRUE ; + + ARRX51(5) := TRUE ; -- RHS VALUES ARE: F T F F T + + + -- INITIALIZATION OF LHS ARRAY: + + FOR I IN IDENT_INT(5)..IDENT_INT(9) LOOP + ARRX52( I ) := TRUE ; -- VALUES WILL BE: T F T T F + END LOOP; + + ARRX52(6) := FALSE ; + + ARRX52(9) := FALSE ; -- LHS VALUES ARE: T F T T F + + + -- NULL SLICE ASSIGNMENT: + + ARRX52( IDENT_INT(6)..IDENT_INT(5) ) := + ARRX51 + ( IDENT_INT(4)..IDENT_INT(4) ) ; + FAILED( "EXCEPTION NOT RAISED - SUBTEST 12" ); + + EXCEPTION + + WHEN CONSTRAINT_ERROR => + + -- CHECKING THE VALUES AFTER THE SLICE ASSIGNMENT: + IF ARRX52( 5 ) /= TRUE OR + ARRX52( 6 ) /= FALSE OR + ARRX52( 7 ) /= TRUE OR + ARRX52( 8 ) /= TRUE OR + ARRX52( 9 ) /= FALSE + THEN + FAILED( "LHS ARRAY ALTERED (12)" ); + END IF; + + WHEN OTHERS => + + FAILED( "WRONG EXCEPTION RAISED - SUBTEST 12" ); + + END ; + + + ------------------------------------------------------------------- + + + RESULT ; + + +END C52104P; diff --git a/gcc/testsuite/ada/acats/tests/c5/c52104q.ada b/gcc/testsuite/ada/acats/tests/c5/c52104q.ada new file mode 100644 index 000000000..dc01ca880 --- /dev/null +++ b/gcc/testsuite/ada/acats/tests/c5/c52104q.ada @@ -0,0 +1,146 @@ +-- C52104Q.ADA + +-- Grant of Unlimited Rights +-- +-- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687, +-- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained +-- unlimited rights in the software and documentation contained herein. +-- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making +-- this public release, the Government intends to confer upon all +-- recipients unlimited rights equal to those held by the Government. +-- These rights include rights to use, duplicate, release or disclose the +-- released technical data and computer software in whole or in part, in +-- any manner and for any purpose whatsoever, and to have or permit others +-- to do so. +-- +-- DISCLAIMER +-- +-- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR +-- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED +-- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF 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 LENGTHS MUST MATCH IN ARRAY AND SLICE ASSIGNMENTS. +-- MORE SPECIFICALLY, TEST THAT ATTEMPTED ASSIGNMENTS BETWEEN +-- ARRAYS WITH NON-MATCHING LENGTHS LEAVE THE DESTINATION ARRAY +-- INTACT AND CAUSE CONSTRAINT_ERROR TO BE RAISED. +-- (OVERLAPS BETWEEN THE OPERANDS OF THE ASSIGNMENT STATEMENT +-- ARE TREATED ELSEWHERE.) + +-- THIS IS THE SECOND FILE IN +-- DIVISION D : NULL LENGTHS NOT DETERMINABLE STATICALLY. + + +-- RM 07/20/81 +-- SPS 3/22/83 +-- JBG 4/24/84 + +WITH REPORT; +PROCEDURE C52104Q IS + + USE REPORT ; + +BEGIN + + TEST( "C52104Q" , "CHECK THAT IN ARRAY ASSIGNMENTS AND IN SLICE" & + " ASSIGNMENTS THE LENGTHS MUST MATCH" ); + + + -- ( EACH DIVISION COMPRISES 3 FILES, + -- COVERING RESPECTIVELY THE FIRST + -- 3 , NEXT 2 , AND LAST 3 OF THE 8 + -- SELECTIONS FOR THE DIVISION.) + + + ------------------------------------------------------------------- + + -- (13) UNSLICED ONE-DIMENSIONAL ARRAY OBJECTS WHOSE TYPEMARKS + -- WERE DEFINED USING THE "BOX" SYMBOL + -- AND FOR WHICH THE COMPONENT TYPE IS 'CHARACTER' . + + DECLARE + + TYPE TABOX3 IS ARRAY( NATURAL RANGE <> ) OF CHARACTER ; + + ARRX31 : TABOX3( IDENT_INT(11)..IDENT_INT(10) ) := "" ; + + BEGIN + + + -- ARRAY ASSIGNMENT (WITH STRING AGGREGATE): + + ARRX31 := "AZ" ; + FAILED( "EXCEPTION NOT RAISED - SUBTEST 13" ); + + EXCEPTION + + WHEN CONSTRAINT_ERROR => + + -- CHECKING THE VALUES AFTER THE SLICE ASSIGNMENT: + + IF ARRX31 /= "" + THEN + FAILED( "ARRAY ASSIGNMENT NOT CORRECT (13)" ); + END IF; + + WHEN OTHERS => + + FAILED( "WRONG EXCEPTION RAISED - SUBTEST 13" ); + + END ; + + + ------------------------------------------------------------------- + + -- (14) SLICED ONE-DIMENSIONAL ARRAY OBJECTS WHOSE TYPEMARKS + -- WERE DEFINED USING THE "BOX" SYMBOL + -- AND FOR WHICH THE COMPONENT TYPE IS 'CHARACTER' . + + DECLARE + + TYPE TABOX4 IS ARRAY( INTEGER RANGE <> ) OF CHARACTER ; + + SUBTYPE TABOX42 IS TABOX4( IDENT_INT(11)..IDENT_INT(15) ); + + ARRX42 : TABOX42 ; + + BEGIN + + -- INITIALIZATION OF LHS ARRAY: + + ARRX42 := "QUINC" ; + + + -- NULL SLICE ASSIGNMENT: + + ARRX42( IDENT_INT(13)..IDENT_INT(12) ) := "ABCD" ; + FAILED( "EXCEPTION NOT RAISED - SUBTEST 14" ); + + EXCEPTION + + WHEN CONSTRAINT_ERROR => + + -- CHECKING THE VALUES AFTER THE SLICE ASSIGNMENT: + + IF ARRX42 /= "QUINC" OR + ARRX42( IDENT_INT(11)..IDENT_INT(15) ) /= "QUINC" + THEN + FAILED( "LHS ARRAY ALTERED (14)" ); + END IF; + + WHEN OTHERS => + + FAILED( "WRONG EXCEPTION RAISED - SUBTEST 14" ); + + END ; + + + ------------------------------------------------------------------- + + + RESULT ; + + +END C52104Q; diff --git a/gcc/testsuite/ada/acats/tests/c5/c52104r.ada b/gcc/testsuite/ada/acats/tests/c5/c52104r.ada new file mode 100644 index 000000000..8b9e3d466 --- /dev/null +++ b/gcc/testsuite/ada/acats/tests/c5/c52104r.ada @@ -0,0 +1,190 @@ +-- C52104R.ADA + +-- Grant of Unlimited Rights +-- +-- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687, +-- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained +-- unlimited rights in the software and documentation contained herein. +-- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making +-- this public release, the Government intends to confer upon all +-- recipients unlimited rights equal to those held by the Government. +-- These rights include rights to use, duplicate, release or disclose the +-- released technical data and computer software in whole or in part, in +-- any manner and for any purpose whatsoever, and to have or permit others +-- to do so. +-- +-- DISCLAIMER +-- +-- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR +-- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED +-- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF 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 LENGTHS MUST MATCH IN ARRAY AND SLICE ASSIGNMENTS. +-- MORE SPECIFICALLY, TEST THAT ATTEMPTED ASSIGNMENTS BETWEEN +-- ARRAYS WITH NON-MATCHING LENGTHS LEAVE THE DESTINATION ARRAY +-- INTACT AND CAUSE CONSTRAINT_ERROR TO BE RAISED. +-- (OVERLAPS BETWEEN THE OPERANDS OF THE ASSIGNMENT STATEMENT +-- ARE TREATED ELSEWHERE.) + +-- THIS IS THE THIRD FILE IN +-- DIVISION D : NULL LENGTHS NOT DETERMINABLE STATICALLY. + + +-- RM 07/20/81 +-- SPS 3/22/83 + +WITH REPORT; +PROCEDURE C52104R IS + + USE REPORT ; + +BEGIN + + TEST( "C52104R" , "CHECK THAT IN ARRAY ASSIGNMENTS AND IN SLICE" & + " ASSIGNMENTS THE LENGTHS MUST MATCH" ); + + + -- ( EACH DIVISION COMPRISES 3 FILES, + -- COVERING RESPECTIVELY THE FIRST + -- 3 , NEXT 2 , AND LAST 3 OF THE 8 + -- SELECTIONS FOR THE DIVISION.) + + + ------------------------------------------------------------------- + + -- (7) UNSLICED OBJECTS OF THE PREDEFINED TYPE 'STRING' (BY + -- THEMSELVES). + + DECLARE + + ARR71 : STRING( IDENT_INT(1)..IDENT_INT(1) ) := "A" ; + ARR72 : STRING( IDENT_INT(5)..IDENT_INT(4) ) := "" ; + + BEGIN + + -- STRING ASSIGNMENT: + + ARR72 := ARR71 ; + FAILED( "EXCEPTION NOT RAISED - SUBTEST 7" ); + + EXCEPTION + + WHEN CONSTRAINT_ERROR => + + -- CHECKING THE VALUES AFTER THE STRING ASSIGNMENT: + + IF ARR72 /= "" + THEN + FAILED( "ORIGINAL VALUE ALTERED (7)" ); + END IF; + + WHEN OTHERS => + FAILED( "WRONG EXCEPTION RAISED - SUBTEST 7" ); + + END ; + + + ------------------------------------------------------------------- + + -- (8) SLICED OBJECTS OF THE PREDEFINED TYPE 'STRING' , WITH + -- STRING LITERALS. + -- + + DECLARE + + ARR82 : STRING( IDENT_INT(5)..IDENT_INT(9) ) ; + + BEGIN + + + -- INITIALIZATION OF LHS ARRAY: + + ARR82( IDENT_INT(5)..IDENT_INT(9) ) := "QUINC" ; + + + -- STRING LITERAL ASSIGNMENT: + + ARR82( IDENT_INT(5)..IDENT_INT(9) ) + ( IDENT_INT(6)..IDENT_INT(9) ) + ( IDENT_INT(6)..IDENT_INT(5) ) := "ABC" ; + FAILED( "EXCEPTION NOT RAISED - SUBTEST 8" ); + + EXCEPTION + + WHEN CONSTRAINT_ERROR => + + -- CHECKING THE VALUES AFTER THE STRING ASSIGNMENT: + + IF ARR82 /= "QUINC" OR + ARR82( IDENT_INT(5)..IDENT_INT(9) ) /= "QUINC" + THEN + FAILED( "ORIGINAL VALUE ALTERED (8)" ); + END IF; + + WHEN OTHERS => + + FAILED( "WRONG EXCEPTION RAISED - SUBTEST 8" ); + + END ; + + + ------------------------------------------------------------------- + + -- (9) SLICED OBJECTS OF THE PREDEFINED TYPE 'STRING' (BY + -- THEMSELVES). + -- + + DECLARE + + SUBTYPE TA92 IS STRING( IDENT_INT(5)..IDENT_INT(9) ) ; + + ARR91 : STRING( IDENT_INT(1)..IDENT_INT(5) ) := "ABCDE" ; + ARR92 : TA92 ; + + BEGIN + + + -- INITIALIZATION OF LHS ARRAY: + + ARR92( IDENT_INT(5)..IDENT_INT(9) ) := "QUINC" ; + + + -- STRING SLICE ASSIGNMENT: + + ARR92( IDENT_INT(5)..IDENT_INT(9) ) + ( IDENT_INT(6)..IDENT_INT(9) ) + ( IDENT_INT(8)..IDENT_INT(7) ) := + ARR91 + ( IDENT_INT(1)..IDENT_INT(5) ) + ( IDENT_INT(5)..IDENT_INT(7) ) ; + FAILED( "EXCEPTION NOT RAISED - SUBTEST 9" ); + + EXCEPTION + + WHEN CONSTRAINT_ERROR => + + -- CHECKING THE VALUES AFTER THE STRING ASSIGNMENT: + + IF ARR92 /= "QUINC" OR + ARR92( IDENT_INT(5)..IDENT_INT(9) ) /= "QUINC" + THEN + FAILED( "ORIGINAL VALUE ALTERED (9)" ); + END IF; + + WHEN OTHERS => + + FAILED( "WRONG EXCEPTION RAISED - SUBTEST 9" ); + + END ; + + + ------------------------------------------------------------------- + + + RESULT ; + + +END C52104R; diff --git a/gcc/testsuite/ada/acats/tests/c5/c52104x.ada b/gcc/testsuite/ada/acats/tests/c5/c52104x.ada new file mode 100644 index 000000000..3db74d7cd --- /dev/null +++ b/gcc/testsuite/ada/acats/tests/c5/c52104x.ada @@ -0,0 +1,222 @@ +-- C52104X.ADA + +-- Grant of Unlimited Rights +-- +-- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687, +-- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained +-- unlimited rights in the software and documentation contained herein. +-- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making +-- this public release, the Government intends to confer upon all +-- recipients unlimited rights equal to those held by the Government. +-- These rights include rights to use, duplicate, release or disclose the +-- released technical data and computer software in whole or in part, in +-- any manner and for any purpose whatsoever, and to have or permit others +-- to do so. +-- +-- DISCLAIMER +-- +-- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR +-- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED +-- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF 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 LENGTHS MUST MATCH IN ARRAY AND SLICE ASSIGNMENTS. +-- MORE SPECIFICALLY, TEST THAT ATTEMPTED ASSIGNMENTS BETWEEN +-- ARRAYS WITH NON-MATCHING LENGTHS LEAVE THE DESTINATION ARRAY +-- INTACT AND CAUSE CONSTRAINT_ERROR TO BE RAISED. +-- (OVERLAPS BETWEEN THE OPERANDS OF THE ASSIGNMENT STATEMENT +-- ARE TREATED ELSEWHERE.) + +-- THIS IS A SPECIAL CASE IN + +-- DIVISION C : NON-NULL ARRAYS WHOSE LENGTHS ARE NOT DETERMINABLE +-- STATICALLY + +-- WHICH TREATS ARRAYS OF LENGTH GREATER THAN INTEGER'LAST . +-- AN ADDITIONAL OBJECTIVE OF THIS TEST IS TO CHECK WHETHER LENGTH +-- COMPARISONS (AND LENGTH COMPUTATIONS) CAUSE +-- CONSTRAINT_ERROR TO BE RAISED. + +-- *** NOTE: This test has been modified since ACVC version 1.11 to -- 9X +-- *** remove incompatibilities associated with the transition -- 9X +-- *** to Ada 9X. -- 9X +-- *** -- 9X + +-- RM 07/31/81 +-- SPS 02/07/83 +-- EG 10/28/85 FIX NUMERIC_ERROR/CONSTRAINT_ERROR ACCORDING TO +-- AI-00387. +-- JRK 06/24/86 FIXED COMMENTS ABOUT NUMERIC_ERROR/CONSTRAINT_ERROR. +-- MRM 03/30/93 REMOVED NUMERIC_ERROR FOR 9X INCOMPATIBILITY + +WITH REPORT; +PROCEDURE C52104X IS + + USE REPORT ; + +BEGIN + + TEST( "C52104X" , "CHECK THAT IN ARRAY ASSIGNMENTS AND IN SLICE " & + "ASSIGNMENTS, THE LENGTHS MUST MATCH; ALSO " & + "CHECK WHETHER CONSTRAINT_ERROR " & + "OR STORAGE_ERROR ARE RAISED FOR LARGE ARRAYS"); + + -- IN THIS TEST WE CAN'T USE AGGREGATE ASSIGNMENT (EXCEPT WHEN + -- THE AGGREGATES ARE STRING LITERALS); THEREFORE: + -- + -- (1) ARRAYS WILL BE INITIALIZED BY INDIVIDUAL ASSIGNMENTS; + -- (2) CAN'T USE NON-NULL CONSTANT ARRAYS. + + + -- WE ASSUME THAT IN AN ARRAY_TYPE_DEFINITION THE INDEX PORTION + -- AND THE COMPONENT_TYPE PORTION ARE FUNCTIONALLY ORTHOGONAL + -- ALSO AT THE IMPLEMENTATION LEVEL, I.E. THAT THE CORRECTNESS + -- OF THE ACCESSING MECHANISM FOR ARRAYS DOES NOT DEPEND ON + -- COMPONENT_TYPE. ACCORDINGLY WE ARE TESTING FOR SOME BUT + -- NOT ALL KINDS OF COMPONENT_TYPE. (COMPONENT_TYPES INCLUDED: + -- INTEGER , CHARACTER , BOOLEAN .) + + + ------------------------------------------------------------------- + + -- (12) SLICED ONE-DIMENSIONAL ARRAY OBJECTS WHOSE TYPEMARKS + -- WERE DEFINED USING THE "BOX" SYMBOL + -- AND FOR WHICH THE COMPONENT TYPE IS NOT 'CHARACTER' . + -- ((ONE-DIMENSIONAL) ARRAYS OF BOOLEANS.) + +CONSTR_ERR: -- THIS BLOCK CATCHES CONSTRAINT_ERROR + -- FOR THE SUBTYPE DECLARATION. + BEGIN + +DCL_ARR: DECLARE -- THIS BLOCK DECLARES THE ARRAY SUBTYPE. + + TYPE TABOX5 IS ARRAY( INTEGER RANGE <> ) OF BOOLEAN ; + PRAGMA PACK (TABOX5); + + SUBTYPE TABOX51 IS TABOX5 + (IDENT_INT(-6)..IDENT_INT(INTEGER'LAST-4)); + -- CONSTRAINT_ERROR MAY BE RAISED BY THIS + -- SUBTYPE DECLARATION. + + BEGIN + + COMMENT ("NO CONSTRAINT_ERROR FOR TYPE " & + "WITH 'LENGTH = INTEGER'LAST + 3"); + +OBJ_DCL: DECLARE -- THIS BLOCK DECLARES TWO BOOLEAN ARRAYS THAT + -- HAVE INTEGER'LAST + 3 COMPONENTS; + -- STORAGE_ERROR MAY BE RAISED. + ARRX51 : TABOX51 ; + ARRX52 : TABOX5 + (IDENT_INT(-2)..IDENT_INT( INTEGER'LAST)); + + BEGIN + + COMMENT ("NO STORAGE_ERROR OR " & + "CONSTRAINT_ERROR RAISED WHEN ALLOCATING TWO " & + "BIG BOOLEAN ARRAYS"); + + -- INITIALIZATION OF LHS ARRAY: + +NO_EXCP: BEGIN -- NO EXCEPTION SHOULD OCCUR IN THIS BLOCK + FOR I IN IDENT_INT(-2)..IDENT_INT(9) LOOP + ARRX52( I ) := FALSE ; + END LOOP; + + + -- INITIALIZATION OF RHS ARRAY: + + -- ONLY A SHORT INITIAL SEGMENT IS INITIALIZED, + -- SINCE A COMPLETE INITIALIZATION MIGHT TAKE TOO LONG + -- AND THE EXECUTION MIGHT BE ABORTED BEFORE THE LENGTH + -- COMPARISON OF THE ARRAY ASSIGNMENT IS ATTEMPTED. + + FOR I IN IDENT_INT(-6)..IDENT_INT(5) LOOP + ARRX51( I ) := TRUE ; + END LOOP; + + EXCEPTION + + WHEN CONSTRAINT_ERROR => + FAILED ("CONSTRAINT_ERROR RAISED WHEN " & + "ASSIGNING TO ARRAY COMPONENTS"); + WHEN OTHERS => + FAILED ("OTHER EXCEPTION RAISED - 1"); + + END NO_EXCP; + +DO_SLICE: BEGIN + -- SLICE ASSIGNMENT: + + ARRX52( IDENT_INT(-1)..IDENT_INT(INTEGER'LAST )) := + ARRX51( + IDENT_INT(-4)..IDENT_INT(INTEGER'LAST-4) ) ; + FAILED( "EXCEPTION NOT RAISED (12)" ); + + EXCEPTION + + WHEN CONSTRAINT_ERROR => + + COMMENT ("CONSTRAINT_ERROR RAISED DURING " & + "CHECK FOR SLICE ASSIGNMENT"); + + -- CHECKING THE VALUES AFTER THE SLICE + -- ASSIGNMENT: + + FOR I IN IDENT_INT(-2)..IDENT_INT(9) LOOP + + IF ARRX52( I ) /= FALSE + THEN + FAILED( "LHS ARRAY ALTERED (12A)"); + END IF; + + END LOOP; + + + WHEN STORAGE_ERROR => + COMMENT ("STORAGE_ERROR RAISED DURING CHECK " & + "FOR SLICE ASSIGNMENT"); + + WHEN OTHERS => + FAILED ("SOME EXCEPTION RAISED DURING SLICE"); + + END DO_SLICE; + + END OBJ_DCL; + + EXCEPTION + + WHEN STORAGE_ERROR => + COMMENT ("STORAGE_ERROR RAISED WHEN DECLARING " & + "TWO PACKED BOOLEAN ARRAYS WITH " & + "INTEGER'LAST + 3 COMPONENTS"); + WHEN CONSTRAINT_ERROR => + COMMENT ("CONSTRAINT_ERROR RAISED WHEN DECLARING " & + "TWO PACKED BOOLEAN ARRAYS WITH " & + "INTEGER'LAST + 3 COMPONENTS"); + WHEN OTHERS => + FAILED ("SOME EXCEPTION RAISED - 3"); + + END DCL_ARR; + + EXCEPTION + + + WHEN CONSTRAINT_ERROR => + COMMENT ("CONSTRAINT_ERROR RAISED WHEN DECLARING AN " & + "ARRAY SUBTYPE WITH INTEGER'LAST + 3 " & + "COMPONENTS"); + + WHEN STORAGE_ERROR => + FAILED ("STORAGE_ERROR RAISED FOR TYPE DECLARATION"); + + WHEN OTHERS => + FAILED ("OTHER EXCEPTION RAISED - 4"); + + END CONSTR_ERR; + + RESULT ; + +END C52104X; diff --git a/gcc/testsuite/ada/acats/tests/c5/c52104y.ada b/gcc/testsuite/ada/acats/tests/c5/c52104y.ada new file mode 100644 index 000000000..220a4a14c --- /dev/null +++ b/gcc/testsuite/ada/acats/tests/c5/c52104y.ada @@ -0,0 +1,174 @@ +-- C52104Y.ADA + +-- Grant of Unlimited Rights +-- +-- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687, +-- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained +-- unlimited rights in the software and documentation contained herein. +-- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making +-- this public release, the Government intends to confer upon all +-- recipients unlimited rights equal to those held by the Government. +-- These rights include rights to use, duplicate, release or disclose the +-- released technical data and computer software in whole or in part, in +-- any manner and for any purpose whatsoever, and to have or permit others +-- to do so. +-- +-- DISCLAIMER +-- +-- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR +-- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED +-- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF 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 LENGTHS MUST MATCH IN ARRAY AND SLICE ASSIGNMENTS. +-- MORE SPECIFICALLY, TEST THAT ATTEMPTED ASSIGNMENTS BETWEEN +-- ARRAYS WITH NON-MATCHING LENGTHS LEAVE THE DESTINATION ARRAY +-- INTACT AND CAUSE CONSTRAINT_ERROR TO BE RAISED. +-- (OVERLAPS BETWEEN THE OPERANDS OF THE ASSIGNMENT STATEMENT +-- ARE TREATED ELSEWHERE.) + +-- THIS IS A SPECIAL CASE IN + +-- DIVISION D : NULL ARRAYS WHOSE LENGTHS ARE NOT DETERMINABLE +-- STATICALLY + +-- WHICH (THE SPECIAL CASE) TREATS TWO-DIMENSIONAL ARRAYS WHOSE LENGTH +-- ALONG ONE DIMENSION IS GREATER THAN INTEGER'LAST AND WHOSE +-- LENGTH ALONG THE OTHER DIMENSION IS 0 . +-- AN ADDITIONAL OBJECTIVE OF THIS TEST IS TO CHECK WHETHER LENGTH +-- COMPARISONS (AND LENGTH COMPUTATIONS) CAUSE CONSTRAINT_ERROR +-- TO BE RAISED. + +-- *** NOTE: This test has been modified since ACVC version 1.11 to -- 9X +-- *** remove incompatibilities associated with the transition -- 9X +-- *** to Ada 9X. -- 9X +-- *** -- 9X + +-- RM 07/31/81 +-- SPS 03/22/83 +-- JBG 06/16/83 +-- EG 10/28/85 FIX NUMERIC_ERROR/CONSTRAINT_ERROR ACCORDING TO +-- AI-00387. +-- MRM 03/30/93 REMOVE NUMERIC_ERROR FOR 9X COMPATIBILITY + +WITH REPORT; +PROCEDURE C52104Y IS + + USE REPORT ; + +BEGIN + + TEST( "C52104Y" , "CHECK THAT IN ARRAY ASSIGNMENTS AND IN SLICE" & + " ASSIGNMENTS, THE LENGTHS MUST MATCH" ); + + -- IN THIS TEST WE CAN'T USE AGGREGATE ASSIGNMENT (EXCEPT WHEN + -- THE AGGREGATES ARE STRING LITERALS); THEREFORE: + -- + -- (1) ARRAYS WILL BE INITIALIZED BY INDIVIDUAL ASSIGNMENTS; + -- (2) CAN'T USE NON-NULL CONSTANT ARRAYS. + + + -- WE ASSUME THAT IN AN ARRAY_TYPE_DEFINITION THE INDEX PORTION + -- AND THE COMPONENT_TYPE PORTION ARE FUNCTIONALLY ORTHOGONAL + -- ALSO AT THE IMPLEMENTATION LEVEL, I.E. THAT THE CORRECTNESS + -- OF THE ACCESSING MECHANISM FOR ARRAYS DOES NOT DEPEND ON + -- COMPONENT_TYPE. ACCORDINGLY WE ARE TESTING FOR SOME BUT + -- NOT ALL KINDS OF COMPONENT_TYPE. (COMPONENT_TYPES INCLUDED: + -- INTEGER , CHARACTER , BOOLEAN .) + + + ------------------------------------------------------------------- + + -- (10) MULTIDIMENSIONAL ARRAY OBJECTS WHOSE TYPEMARKS WERE + -- DEFINED USING THE "BOX" COMPOUND SYMBOL. + -- (TWO-DIMENSIONAL ARRAYS OF BOOLEANS.) + +CONSTR_ERR: + BEGIN -- THIS BLOCK CATCHES CONSTRAINT_ERROR IF IT IS + -- RAISED BY THE SUBTYPE DECLARATION. + +DCL_ARR: DECLARE + + TYPE TABOX5 IS ARRAY( INTEGER RANGE <> , + INTEGER RANGE <> ) OF BOOLEAN ; + PRAGMA PACK (TABOX5); + + SUBTYPE TABOX52 IS TABOX5( + IDENT_INT(13)..IDENT_INT( 13 ) , + IDENT_INT(-6)..IDENT_INT( INTEGER'LAST-4 ) ); + + BEGIN + + COMMENT ("NO CONSTRAINT_ERROR FOR NON-NULL ARRAY SUBTYPE " & + "WHEN ONE DIMENSION HAS INTEGER'LAST + 3 " & + "COMPONENTS"); + +OBJ_DCL: DECLARE -- THIS BLOCK DECLARES ONE NULL ARRAY AND ONE + -- PACKED BOOLEAN ARRAY WITH INTEGER'LAST + 3 + -- COMPONENTS; STORAGE ERROR MAY BE RAISED. + + ARRX51 : TABOX5( + IDENT_INT(13)..IDENT_INT( 12 ) , + IDENT_INT(-6)..IDENT_INT( INTEGER'LAST-4 ) ); + ARRX52 : TABOX52 ; -- BIG ARRAY HERE. + + BEGIN + + COMMENT ("NO CONSTRAINT OR STORAGE ERROR WHEN ARRAY "& + "WITH INTEGER'LAST+3 COMPONENTS ALLOCATED"); + + -- NULL ARRAY ASSIGNMENT: + + ARRX52 := ARRX51 ; + FAILED( "EXCEPTION NOT RAISED (10)" ); + + EXCEPTION + + WHEN CONSTRAINT_ERROR => + COMMENT ("CONSTRAINT_ERROR RAISED WHEN " & + "CHECKING LENGTHS FOR ARRAY HAVING " & + "> INTEGER'LAST COMPONENTS ON ONE " & + "DIMENSION"); + + + WHEN OTHERS => + FAILED( "OTHER EXCEPTION RAISED - SUBTEST 10"); + + END OBJ_DCL; + + EXCEPTION + + WHEN STORAGE_ERROR => + COMMENT ("STORAGE_ERROR RAISED WHEN DECLARING ONE "& + "PACKED BOOLEAN ARRAY WITH INTEGER'LAST "& + "+ 3 COMPONENTS"); + WHEN CONSTRAINT_ERROR => + COMMENT ("CONSTRAINT_ERROR RAISED WHEN DECLARING "& + "ONE PACKED BOOLEAN ARRAY WITH "& + "INTEGER'LAST + 3 COMPONENTS"); + WHEN OTHERS => + FAILED ("SOME EXCEPTION RAISED - 3"); + + END DCL_ARR; + + EXCEPTION + + + WHEN CONSTRAINT_ERROR => + COMMENT ("CONSTRAINT_ERROR RAISED WHEN DECLARING AN " & + "ARRAY SUBTYPE WITH INTEGER'LAST + 3 " & + "COMPONENTS"); + + WHEN STORAGE_ERROR => + FAILED ("STORAGE_ERROR RAISED FOR TYPE DECLARATION"); + + WHEN OTHERS => + FAILED( "OTHER EXCEPTION RAISED - 4"); + + END CONSTR_ERR; + + RESULT ; + +END C52104Y; diff --git a/gcc/testsuite/ada/acats/tests/c5/c53007a.ada b/gcc/testsuite/ada/acats/tests/c5/c53007a.ada new file mode 100644 index 000000000..bda27b919 --- /dev/null +++ b/gcc/testsuite/ada/acats/tests/c5/c53007a.ada @@ -0,0 +1,139 @@ +-- C53007A.ADA + +-- Grant of Unlimited Rights +-- +-- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687, +-- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained +-- unlimited rights in the software and documentation contained herein. +-- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making +-- this public release, the Government intends to confer upon all +-- recipients unlimited rights equal to those held by the Government. +-- These rights include rights to use, duplicate, release or disclose the +-- released technical data and computer software in whole or in part, in +-- any manner and for any purpose whatsoever, and to have or permit others +-- to do so. +-- +-- DISCLAIMER +-- +-- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR +-- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED +-- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF 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 CONTROL FLOWS CORRECTLY IN SIMPLE NESTED IF_STATEMENTS. + +-- JRK 7/23/80 +-- SPS 3/4/83 + +WITH REPORT; +PROCEDURE C53007A IS + + USE REPORT; + + CI1 : CONSTANT INTEGER := 1; + CI9 : CONSTANT INTEGER := 9; + CBT : CONSTANT BOOLEAN := TRUE; + CBF : CONSTANT BOOLEAN := FALSE; + + VI1 : INTEGER := IDENT_INT(1); + VI9 : INTEGER := IDENT_INT(9); + VBT : BOOLEAN := IDENT_BOOL(TRUE); + VBF : BOOLEAN := IDENT_BOOL(FALSE); + + FLOW_COUNT : INTEGER := 0; + +BEGIN + TEST ("C53007A", "CHECK THAT CONTROL FLOWS CORRECTLY IN SIMPLE " & + "NESTED IF_STATEMENTS"); + + IF VBF THEN -- (FALSE) + FAILED ("INCORRECT CONTROL FLOW 1"); + ELSIF CI9 < 20 THEN -- (TRUE) + FLOW_COUNT := FLOW_COUNT + 1; + IF VI1 /= 0 AND TRUE THEN -- (TRUE) + FLOW_COUNT := FLOW_COUNT + 1; + ELSE FAILED ("INCORRECT CONTROL FLOW 2"); + END IF; + ELSE FAILED ("INCORRECT CONTROL FLOW 3"); + END IF; + + IF CBF OR ELSE VI9 = 9 THEN -- (TRUE) + IF VI1 + CI9 > 0 OR (CBF AND VBT) THEN -- (TRUE) + FLOW_COUNT := FLOW_COUNT + 1; + END IF; + ELSIF VBF OR VI1 > 10 THEN -- (FALSE) + FAILED ("INCORRECT CONTROL FLOW 4"); + END IF; + + IF NOT CBT AND THEN NOT VBT AND THEN CI9 < 0 THEN -- (FALSE) + IF FALSE OR NOT TRUE THEN -- (FALSE) + FAILED ("INCORRECT CONTROL FLOW 5"); + ELSIF VI1 >= 0 THEN -- (TRUE) + NULL; + ELSE FAILED ("INCORRECT CONTROL FLOW 6"); + END IF; + FAILED ("INCORRECT CONTROL FLOW 7"); + ELSIF (VI1 * CI9 + 3 < 0) OR (VBT AND NOT (CI1 < 0)) THEN -- (TRUE) + FLOW_COUNT := FLOW_COUNT + 1; + IF NOT CBT OR ELSE CI9 + 1 = 0 THEN -- (FALSE) + FAILED ("INCORRECT CONTROL FLOW 8"); + ELSE FLOW_COUNT := FLOW_COUNT + 1; + IF VI1 * 2 > 0 THEN -- (TRUE) + FLOW_COUNT := FLOW_COUNT + 1; + ELSIF TRUE THEN -- (TRUE) + FAILED ("INCORRECT CONTROL FLOW 9"); + ELSE NULL; + END IF; + END IF; + ELSIF FALSE AND CBF THEN -- (FALSE) + FAILED ("INCORRECT CONTROL FLOW 10"); + ELSE IF VBT THEN -- (TRUE) + FAILED ("INCORRECT CONTROL FLOW 11"); + ELSIF VI1 = 0 THEN -- (FALSE) + FAILED ("INCORRECT CONTROL FLOW 12"); + ELSE FAILED ("INCORRECT CONTROL FLOW 13"); + END IF; + END IF; + + IF 3 = 5 OR NOT VBT THEN -- (FALSE) + FAILED ("INCORRECT CONTROL FLOW 14"); + IF TRUE AND CBT THEN -- (TRUE) + FAILED ("INCORRECT CONTROL FLOW 15"); + ELSE FAILED ("INCORRECT CONTROL FLOW 16"); + END IF; + ELSIF CBF THEN -- (FALSE) + IF VI9 >= 0 OR FALSE THEN -- (TRUE) + IF VBT THEN -- (TRUE) + FAILED ("INCORRECT CONTROL FLOW 17"); + END IF; + FAILED ("INCORRECT CONTROL FLOW 18"); + ELSIF VI1 + CI9 /= 0 THEN -- (TRUE) + FAILED ("INCORRECT CONTROL FLOW 19"); + END IF; + FAILED ("INCORRECT CONTROL FLOW 20"); + ELSE IF VBT AND CI9 - 9 = 0 THEN -- (TRUE) + IF FALSE THEN -- (FALSE) + FAILED ("INCORRECT CONTROL FLOW 21"); + ELSIF NOT VBF AND THEN CI1 > 0 THEN -- (TRUE) + FLOW_COUNT := FLOW_COUNT + 1; + ELSE FAILED ("INCORRECT CONTROL FLOW 22"); + END IF; + FLOW_COUNT := FLOW_COUNT + 1; + ELSIF NOT CBF OR VI1 /= 0 THEN -- (TRUE) + IF VBT THEN -- (TRUE) + NULL; + END IF; + FAILED ("INCORRECT CONTROL FLOW 23"); + ELSE FAILED ("INCORRECT CONTROL FLOW 24"); + END IF; + FLOW_COUNT := FLOW_COUNT + 1; + END IF; + + IF FLOW_COUNT /= 9 THEN + FAILED ("INCORRECT FLOW_COUNT VALUE"); + END IF; + + RESULT; +END C53007A; diff --git a/gcc/testsuite/ada/acats/tests/c5/c540001.a b/gcc/testsuite/ada/acats/tests/c5/c540001.a new file mode 100644 index 000000000..b7dbdd6e9 --- /dev/null +++ b/gcc/testsuite/ada/acats/tests/c5/c540001.a @@ -0,0 +1,410 @@ +-- C540001.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 expression in a case statement may be of a generic formal +-- type. Check that a function call may be used as a case statement +-- expression. Check that a call to a generic formal function may be +-- used as a case statement expression. Check that a call to an inherited +-- function may be used as a case statement expression even if its result +-- type does not correspond to any nameable subtype. +-- +-- TEST DESCRIPTION: +-- This transition test creates examples where expressions in a case +-- statement can be a generic formal object and a call to a generic formal +-- function. This test also creates examples when either a function call, +-- a renaming of a function, or a call to an inherited function is used +-- in the case expressions, the choices of the case statement only need +-- to cover the values in the result of the function. +-- +-- Inspired by B54A08A.ADA. +-- +-- +-- CHANGE HISTORY: +-- 12 Feb 96 SAIC Initial version for ACVC 2.1. +-- +--! + +package C540001_0 is + type Int is range 1 .. 2; + +end C540001_0; + + --==================================================================-- + +with C540001_0; +package C540001_1 is + type Enum_Type is (Eh, Bee, Sea, Dee); -- Range of Enum_Type'Val is 0..3. + type Mixed is ('A','B', 'C', None); + subtype Small_Num is Natural range 0 .. 10; + type Small_Int is range 1 .. 2; + function Get_Small_Int (P : Boolean) return Small_Int; + procedure Assign_Mixed (P1 : in Boolean; + P2 : out Mixed); + + type Tagged_Type is tagged + record + C1 : Enum_Type; + end record; + function Get_Tagged (P : Tagged_Type) return C540001_0.Int; + +end C540001_1; + + --==================================================================-- + +package body C540001_1 is + function Get_Small_Int (P : Boolean) return Small_Int is + begin + if P then + return Small_Int'First; + else + return Small_Int'Last; + end if; + end Get_Small_Int; + + --------------------------------------------------------------------- + procedure Assign_Mixed (P1 : in Boolean; + P2 : out Mixed) is + begin + case Get_Small_Int (P1) is -- Function call as expression + when 1 => P2 := None; -- in case statement. + when 2 => P2 := 'A'; + -- No others needed. + end case; + + end Assign_Mixed; + + --------------------------------------------------------------------- + function Get_Tagged (P : Tagged_Type) return C540001_0.Int is + begin + return C540001_0.Int'Last; + end Get_Tagged; + +end C540001_1; + + --==================================================================-- + +generic + + type Formal_Scalar is range <>; + + FSO : Formal_Scalar; + +package C540001_2 is + + type Enum is (Alpha, Beta, Theta); + + procedure Assign_Enum (ET : out Enum); + +end C540001_2; + + --==================================================================-- + +package body C540001_2 is + + procedure Assign_Enum (ET : out Enum) is + begin + case FSO is -- Type of expression in case + when 1 => ET := Alpha; -- statement is generic formal type. + when 2 => ET := Beta; + when others => ET := Theta; + end case; + + end Assign_Enum; + +end C540001_2; + + --==================================================================-- + +with C540001_1; +generic + + type Formal_Enum_Type is new C540001_1.Enum_Type; + + with function Formal_Func (P : C540001_1.Small_Num) + return Formal_Enum_Type is <>; + +function C540001_3 (P : C540001_1.Small_Num) return Formal_Enum_Type; + + --==================================================================-- + +function C540001_3 (P : C540001_1.Small_Num) return Formal_Enum_Type is + +begin + return Formal_Func (P); +end C540001_3; + + --==================================================================-- + +with C540001_1; +generic + + type Formal_Int_Type is new C540001_1.Small_Int; + + with function Formal_Func return Formal_Int_Type; + +package C540001_4 is + + procedure Gen_Assign_Mixed (P : out C540001_1.Mixed); + +end C540001_4; + + --==================================================================-- + +package body C540001_4 is + + procedure Gen_Assign_Mixed (P : out C540001_1.Mixed) is + begin + case Formal_Func is -- Case expression is + when 1 => P := C540001_1.'A'; -- generic function. + when others => P := C540001_1.'B'; + end case; + + end Gen_Assign_Mixed; + +end C540001_4; + + --==================================================================-- + +with C540001_1; +package C540001_5 is + type New_Tagged is new C540001_1.Tagged_Type with + record + C2 : C540001_1.Mixed; + end record; + + -- Inherits Get_Tagged (P : New_Tagged) return C540001_0.Int; + -- Note that the return type of the inherited function is not + -- nameable here. + + procedure Assign_Tagged (P1 : in New_Tagged; + P2 : out New_Tagged); + +end C540001_5; + + --==================================================================-- + +package body C540001_5 is + + procedure Assign_Tagged (P1 : in New_Tagged; + P2 : out New_Tagged) is + begin + case Get_Tagged (P1) is -- Case expression is + -- inherited function. + when 2 => P2 := (C540001_1.Bee, 'B'); + when others => P2 := (C540001_1.Sea, C540001_1.None); + end case; + + end Assign_Tagged; + +end C540001_5; + + --==================================================================-- + +with Report; +with C540001_1; +with C540001_2; +with C540001_3; +with C540001_4; +with C540001_5; + +procedure C540001 is + type Value is range 1 .. 5; + +begin + Report.Test ("C540001", "Check that an expression in a case statement " & + "may be of a generic formal type. Check that a function " & + "call may be used as a case statement expression. Check " & + "that a call to a generic formal function may be used as " & + "a case statement expression. Check that a call to an " & + "inherited function may be used as a case statement " & + "expression"); + + Generic_Formal_Object_Subtest: + begin + declare + One : Value := 1; + package One_Pck is new C540001_2 (Value, One); + use One_Pck; + EObj : Enum; + begin + Assign_Enum (EObj); + if EObj /= Alpha then + Report.Failed ("Incorrect result for value of one in generic" & + "formal object subtest"); + end if; + end; + + declare + Five : Value := 5; + package Five_Pck is new C540001_2 (Value, Five); + use Five_Pck; + EObj : Enum; + begin + Assign_Enum (EObj); + if EObj /= Theta then + Report.Failed ("Incorrect result for value of five in generic" & + "formal object subtest"); + end if; + end; + + end Generic_Formal_Object_Subtest; + + Instantiated_Generic_Function_Subtest: + declare + type New_Enum_Type is new C540001_1.Enum_Type; + + function Get_Enum_Value (P : C540001_1.Small_Num) + return New_Enum_Type is + begin + return New_Enum_Type'Val (P); + end Get_Enum_Value; + + function Val_Func is new C540001_3 + (Formal_Enum_Type => New_Enum_Type, + Formal_Func => Get_Enum_Value); + + procedure Assign_Num (P : in out C540001_1.Small_Num) is + begin + case Val_Func (P) is -- Case expression is + -- instantiated generic + when New_Enum_Type (C540001_1.Eh) | -- function. + New_Enum_Type (C540001_1.Sea) => P := 4; + when New_Enum_Type (C540001_1.Bee) => P := 7; + when others => P := 9; + end case; + + end Assign_Num; + + SNObj : C540001_1.Small_Num; + + begin + SNObj := 0; + Assign_Num (SNObj); + if SNObj /= 4 then + Report.Failed ("Incorrect result for value of zero in call to " & + "generic function subtest"); + end if; + + SNObj := 3; + Assign_Num (SNObj); + if SNObj /= 9 then + Report.Failed ("Incorrect result for value of three in call to " & + "generic function subtest"); + end if; + + end Instantiated_Generic_Function_Subtest; + + -- When a function call, a renaming of a function, or a call to an + -- inherited function is used in the case expressions, the choices + -- of the case statement only need to cover the values in the result + -- of the function. + + Function_Call_Subtest: + declare + MObj : C540001_1.Mixed := 'B'; + BObj : Boolean := True; + use type C540001_1.Mixed; + begin + C540001_1.Assign_Mixed (BObj, MObj); + if MObj /= C540001_1.None then + Report.Failed ("Incorrect result for value of true in function" & + "call subtest"); + end if; + + BObj := False; + C540001_1.Assign_Mixed (BObj, MObj); + if MObj /= C540001_1.'A' then + Report.Failed ("Incorrect result for value of false in function" & + "call subtest"); + end if; + + end Function_Call_Subtest; + + Function_Renaming_Subtest: + declare + use C540001_1; + function Rename_Get_Small_Int (P : Boolean) + return Small_Int renames Get_Small_Int; + MObj : Mixed := None; + BObj : Boolean := False; + begin + case Rename_Get_Small_Int (BObj) is + when 1 => MObj := 'A'; + when 2 => MObj := 'B'; + -- No others needed. + end case; + + if MObj /= 'B' then + Report.Failed ("Incorrect result for value of false in function" & + "renaming subtest"); + end if; + + end Function_Renaming_Subtest; + + Call_To_Generic_Formal_Function_Subtest: + declare + type New_Small_Int is new C540001_1.Small_Int; + + function Get_Int_Value return New_Small_Int is + begin + return New_Small_Int'First; + end Get_Int_Value; + + package Int_Pck is new C540001_4 + (Formal_Int_Type => New_Small_Int, + Formal_Func => Get_Int_Value); + + use type C540001_1.Mixed; + MObj : C540001_1.Mixed := C540001_1.None; + + begin + Int_Pck.Gen_Assign_Mixed (MObj); + if MObj /= C540001_1.'A' then + Report.Failed ("Incorrect result in call to generic formal " & + "function subtest"); + end if; + + end Call_To_Generic_Formal_Function_Subtest; + + Call_To_Inherited_Function_Subtest: + declare + NTObj1 : C540001_5.New_Tagged := (C1 => C540001_1.Eh, + C2 => C540001_1.'A'); + NTObj2 : C540001_5.New_Tagged := (C540001_1.Dee, C540001_1.'C'); + use type C540001_1.Mixed; + use type C540001_1.Enum_Type; + begin + C540001_5.Assign_Tagged (NTObj1, NTObj2); + if NTObj2.C1 /= C540001_1.Bee or + NTObj2.C2 /= C540001_1.'B' then + Report.Failed ("Incorrect result in inherited function subtest"); + end if; + + end Call_To_Inherited_Function_Subtest; + + Report.Result; + +end C540001; diff --git a/gcc/testsuite/ada/acats/tests/c5/c54a03a.ada b/gcc/testsuite/ada/acats/tests/c5/c54a03a.ada new file mode 100644 index 000000000..cc46df8c6 --- /dev/null +++ b/gcc/testsuite/ada/acats/tests/c5/c54a03a.ada @@ -0,0 +1,105 @@ +-- C54A03A.ADA + +-- Grant of Unlimited Rights +-- +-- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687, +-- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained +-- unlimited rights in the software and documentation contained herein. +-- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making +-- this public release, the Government intends to confer upon all +-- recipients unlimited rights equal to those held by the Government. +-- These rights include rights to use, duplicate, release or disclose the +-- released technical data and computer software in whole or in part, in +-- any manner and for any purpose whatsoever, and to have or permit others +-- to do so. +-- +-- DISCLAIMER +-- +-- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR +-- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED +-- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF 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 BOOLEAN, CHARACTER, USER-DEFINED ENUMERATED, INTEGER, +-- AND DERIVED TYPES MAY BE USED IN A CASE EXPRESSION. + +-- DAT 1/22/81 +-- PWB 4/22/86 RENAME TO -AB; +-- REMOVE EXTRANEOUS <CR> FROM BEGINNING OF LINE 45. + +WITH REPORT; +PROCEDURE C54A03A IS + + USE REPORT; + + TYPE D_INT IS NEW INTEGER RANGE 1 .. 2; + TYPE D_BOOL IS NEW BOOLEAN; + TYPE D_BOOL_2 IS NEW D_BOOL; + TYPE M_ENUM IS (FIRST, SECOND, THIRD); + TYPE M_CHAR IS NEW CHARACTER RANGE ASCII.NUL .. 'Z'; + TYPE M_ENUM_2 IS NEW M_ENUM; + + I : INTEGER := 1; + D_I : D_INT := 1; + B : BOOLEAN := TRUE; + D_B : D_BOOL := TRUE; + D_B_2 : D_BOOL_2 := FALSE; + E : M_ENUM := THIRD; + C : CHARACTER := 'A'; + M_C : M_CHAR := 'Z'; + D_E : M_ENUM_2 := SECOND; + +BEGIN + TEST ("C54A03A", "CHECK VARIOUS DISCRETE TYPES " & + "IN CASE EXPRESSIONS"); + + CASE I IS + WHEN 2 | 3 => FAILED ("WRONG CASE 1"); + WHEN 1 => NULL; + WHEN OTHERS => FAILED ("WRONG CASE 2"); + END CASE; + + CASE D_I IS + WHEN 1 => NULL; + WHEN 2 => FAILED ("WRONG CASE 2A"); + END CASE; + + CASE B IS + WHEN TRUE => NULL; + WHEN FALSE => FAILED ("WRONG CASE 3"); + END CASE; + + CASE D_B IS + WHEN TRUE => NULL; + WHEN FALSE => FAILED ("WRONG CASE 4"); + END CASE; + + CASE D_B_2 IS + WHEN FALSE => NULL; + WHEN TRUE => FAILED ("WRONG CASE 5"); + END CASE; + + CASE E IS + WHEN SECOND | FIRST => FAILED ("WRONG CASE 6"); + WHEN THIRD => NULL; + END CASE; + + CASE C IS + WHEN 'A' .. 'Z' => NULL; + WHEN OTHERS => FAILED ("WRONG CASE 7"); + END CASE; + + CASE M_C IS + WHEN 'Z' => NULL; + WHEN OTHERS => FAILED ("WRONG CASE 8"); + END CASE; + + CASE D_E IS + WHEN FIRST => FAILED ("WRONG CASE 9"); + WHEN SECOND | THIRD => NULL; + END CASE; + + RESULT; +END C54A03A; diff --git a/gcc/testsuite/ada/acats/tests/c5/c54a04a.ada b/gcc/testsuite/ada/acats/tests/c5/c54a04a.ada new file mode 100644 index 000000000..c52de5003 --- /dev/null +++ b/gcc/testsuite/ada/acats/tests/c5/c54a04a.ada @@ -0,0 +1,75 @@ +-- C54A04A.ADA + +-- Grant of Unlimited Rights +-- +-- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687, +-- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained +-- unlimited rights in the software and documentation contained herein. +-- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making +-- this public release, the Government intends to confer upon all +-- recipients unlimited rights equal to those held by the Government. +-- These rights include rights to use, duplicate, release or disclose the +-- released technical data and computer software in whole or in part, in +-- any manner and for any purpose whatsoever, and to have or permit others +-- to do so. +-- +-- DISCLAIMER +-- +-- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR +-- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED +-- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE +-- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE +-- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A +-- PARTICULAR PURPOSE OF SAID MATERIAL. +--* +-- CHECK THAT PRIVATE (DISCRETE) TYPES MAY BE USED IN CASE EXPRESSIONS +-- WITHIN THE DEFINING PACKAGE. + +-- DAT 1/29/81 + +WITH REPORT; +PROCEDURE C54A04A IS + + USE REPORT; + + PACKAGE P IS + + TYPE T IS PRIVATE; + TYPE LT IS LIMITED PRIVATE; + + PRIVATE + + TYPE T IS ('Z', X); + TYPE LT IS NEW INTEGER RANGE 0 .. 1; + + END P; + + VT : P.T; + VLT : P.LT; + + PACKAGE BODY P IS + + BEGIN + TEST ("C54A04A", "PRIVATE DISCRETE TYPES MAY APPEAR IN " & + "CASE EXPRESSIONS IN PACKAGE BODY"); + + VT := 'Z'; + VLT := LT (IDENT_INT (1)); + + CASE VT IS + WHEN X => FAILED ("WRONG CASE 1"); + WHEN 'Z' => NULL; -- OK + END CASE; + + CASE VLT IS + WHEN 1 => NULL; -- OK + WHEN 0 => FAILED ("WRONG CASE 2"); + END CASE; + END P; + +BEGIN + + -- TEST CALLED FROM PACKAGE BODY, ALREADY ELABORATED. + + RESULT; +END C54A04A; diff --git a/gcc/testsuite/ada/acats/tests/c5/c54a07a.ada b/gcc/testsuite/ada/acats/tests/c5/c54a07a.ada new file mode 100644 index 000000000..0729b802f --- /dev/null +++ b/gcc/testsuite/ada/acats/tests/c5/c54a07a.ada @@ -0,0 +1,111 @@ +-- C54A07A.ADA + +-- Grant of Unlimited Rights +-- +-- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687, +-- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained +-- unlimited rights in the software and documentation contained herein. +-- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making +-- this public release, the Government intends to confer upon all +-- recipients unlimited rights equal to those held by the Government. +-- These rights include rights to use, duplicate, release or disclose the +-- released technical data and computer software in whole or in part, in +-- any manner and for any purpose whatsoever, and to have or permit others +-- to do so. +-- +-- DISCLAIMER +-- +-- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR +-- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED +-- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF 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 VARIABLE USED AS A CASE EXPRESSION IS NOT CONSIDERED +-- LOCAL TO THE CASE STATEMENT. IN PARTICULAR, CHECK THAT THE +-- VARIABLE CAN BE ASSIGNED A NEW VALUE, AND THE ASSIGNMENT TAKES +-- EFFECT IMMEDIATELY (I.E. THE CASE STATEMENT DOES NOT USE A +-- COPY OF THE CASE EXPRESSION). + + +-- RM 01/21/80 + + +WITH REPORT ; +PROCEDURE C54A07A IS + + USE REPORT ; + +BEGIN + + TEST("C54A07A" , "CHECK THAT A VARIABLE USED AS A CASE" & + " EXPRESSION IS NOT CONSIDERED LOCAL TO" & + " THE CASE STATEMENT" ); + + DECLARE -- A + BEGIN + +B1 : DECLARE + + TYPE VARIANT_REC( DISCR : BOOLEAN := TRUE ) IS + RECORD + A , B : INTEGER ; + CASE DISCR IS + WHEN TRUE => P , Q : CHARACTER ; + WHEN FALSE => X , Y : INTEGER ; + END CASE; + END RECORD ; + + V : VARIANT_REC := ( TRUE , 1 , 2 , + IDENT_CHAR( 'P' ) , + IDENT_CHAR( 'Q' ) ); + + BEGIN + + IF EQUAL( 3 , 7 ) THEN V := ( FALSE , 3 , 4 , 7 , 8 ); + END IF; + + CASE V.DISCR IS + + WHEN TRUE => + + IF ( V.P /= 'P' OR + V.Q /= 'Q' ) + THEN FAILED( "WRONG VALUES - 1" ); + END IF; + + B1.V := ( FALSE , 3 , 4 , + IDENT_INT( 5 ) , + IDENT_INT( 6 ) ); + + IF V.DISCR THEN FAILED( "WRONG DISCR." ); + END IF; + + IF ( V.X /= 5 OR + V.Y /= 6 ) + THEN FAILED( "WRONG VALUES - 2" ); + END IF; + + WHEN FALSE => + FAILED( "WRONG BRANCH IN CASE STMT." ); + + END CASE; + + EXCEPTION + + WHEN OTHERS => FAILED("EXCEPTION RAISED"); + + END B1 ; + + EXCEPTION + + WHEN OTHERS => FAILED( "EXCEPTION RAISED BY DECLARATIONS"); + + END ; -- A + + + RESULT ; + + +END C54A07A ; diff --git a/gcc/testsuite/ada/acats/tests/c5/c54a13a.ada b/gcc/testsuite/ada/acats/tests/c5/c54a13a.ada new file mode 100644 index 000000000..949de8112 --- /dev/null +++ b/gcc/testsuite/ada/acats/tests/c5/c54a13a.ada @@ -0,0 +1,109 @@ +-- C54A13A.ADA + +-- Grant of Unlimited Rights +-- +-- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687, +-- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained +-- unlimited rights in the software and documentation contained herein. +-- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making +-- this public release, the Government intends to confer upon all +-- recipients unlimited rights equal to those held by the Government. +-- These rights include rights to use, duplicate, release or disclose the +-- released technical data and computer software in whole or in part, in +-- any manner and for any purpose whatsoever, and to have or permit others +-- to do so. +-- +-- DISCLAIMER +-- +-- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR +-- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED +-- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE +-- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE +-- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A +-- PARTICULAR PURPOSE OF SAID MATERIAL. +--* +-- OBJECTIVE: +-- CHECK THAT IF A CASE EXPRESSION IS A DECLARED VARIABLE OR +-- CONSTANT, OR ONE OF THESE IN PARENTHESES, AND ITS SUBTYPE IS +-- NONSTATIC, THEN ANY VALUE OF THE EXPRESSION'S BASE TYPE MAY +-- APPEAR AS A CHOICE. + +-- HISTORY: +-- BCB 02/29/88 CREATED ORIGINAL TEST. + +WITH REPORT; USE REPORT; + +PROCEDURE C54A13A IS + + SUBTYPE INT IS INTEGER RANGE IDENT_INT(5) .. IDENT_INT(10); + + A : INT := 8; + B : CONSTANT INT := 7; + C, D : INTEGER; + + FUNCTION IDENT(X : INT) RETURN INT IS + BEGIN + IF EQUAL(3,3) THEN + RETURN X; + ELSE + RETURN 0; + END IF; + END IDENT; + +BEGIN + TEST ("C54A13A", "CHECK THAT IF A CASE EXPRESSION IS A DECLARED " & + "VARIABLE OR CONSTANT, OR ONE OF THESE IN " & + "PARENTHESES, AND ITS SUBTYPE IS NONSTATIC, " & + "THEN ANY VALUE OF THE EXPRESSION'S BASE TYPE " & + "MAY APPEAR AS A CHOICE"); + + CASE A IS + WHEN 0 => C := IDENT_INT(5); + WHEN 8 => C := IDENT_INT(10); + WHEN 30000 => C := IDENT_INT(15); + WHEN -30000 => C := IDENT_INT(20); + WHEN OTHERS => C := IDENT_INT(25); + END CASE; + + IF C /= IDENT_INT(10) THEN + FAILED ("IMPROPER VALUE FOR CASE EXPRESSION - 1"); + END IF; + + CASE B IS + WHEN 0 => D := IDENT_INT(5); + WHEN 100 => D := IDENT_INT(10); + WHEN 30000 => D := IDENT_INT(15); + WHEN -30000 => D := IDENT_INT(20); + WHEN OTHERS => D := IDENT_INT(25); + END CASE; + + IF D /= IDENT_INT(25) THEN + FAILED ("IMPROPER VALUE FOR CASE EXPRESSION - 2"); + END IF; + + CASE (A) IS + WHEN 0 => C := IDENT_INT(5); + WHEN 8 => C := IDENT_INT(10); + WHEN 30000 => C := IDENT_INT(15); + WHEN -30000 => C := IDENT_INT(20); + WHEN OTHERS => C := IDENT_INT(25); + END CASE; + + IF C /= IDENT_INT(10) THEN + FAILED ("IMPROPER VALUE FOR CASE EXPRESSION - 3"); + END IF; + + CASE (B) IS + WHEN 0 => D := IDENT_INT(5); + WHEN 110 => D := IDENT_INT(10); + WHEN 30000 => D := IDENT_INT(15); + WHEN -30000 => D := IDENT_INT(20); + WHEN OTHERS => D := IDENT_INT(25); + END CASE; + + IF D /= IDENT_INT(25) THEN + FAILED ("IMPROPER VALUE FOR CASE EXPRESSION - 4"); + END IF; + + RESULT; +END C54A13A; diff --git a/gcc/testsuite/ada/acats/tests/c5/c54a13b.ada b/gcc/testsuite/ada/acats/tests/c5/c54a13b.ada new file mode 100644 index 000000000..b0f3d1aea --- /dev/null +++ b/gcc/testsuite/ada/acats/tests/c5/c54a13b.ada @@ -0,0 +1,105 @@ +-- C54A13B.ADA + +-- Grant of Unlimited Rights +-- +-- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687, +-- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained +-- unlimited rights in the software and documentation contained herein. +-- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making +-- this public release, the Government intends to confer upon all +-- recipients unlimited rights equal to those held by the Government. +-- These rights include rights to use, duplicate, release or disclose the +-- released technical data and computer software in whole or in part, in +-- any manner and for any purpose whatsoever, and to have or permit others +-- to do so. +-- +-- DISCLAIMER +-- +-- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR +-- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED +-- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE +-- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE +-- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A +-- PARTICULAR PURPOSE OF SAID MATERIAL. +--* +-- OBJECTIVE: +-- CHECK THAT IF A CASE EXPRESSION IS A GENERIC "IN" OR "IN OUT" +-- PARAMETER WITH A NON-STATIC SUBTYPE OR ONE OF THESE IN +-- PARENTHESES, THEN ANY VALUE OF THE EXPRESSION'S BASE TYPE MAY +-- APPEAR AS A CHOICE. + +-- HISTORY: +-- BCB 07/13/88 CREATED ORIGINAL TEST. + +WITH REPORT; USE REPORT; + +PROCEDURE C54A13B IS + + L : INTEGER := IDENT_INT(1); + R : INTEGER := IDENT_INT(100); + + SUBTYPE INT IS INTEGER RANGE L .. R; + + GENERIC + IN_PAR : IN INT; + IN_OUT_PAR : IN OUT INT; + PROCEDURE GEN_PROC (I : IN OUT INTEGER); + + IN_VAR : INT := IDENT_INT (10); + IN_OUT_VAR : INT := IDENT_INT (100); + CHECK_VAR : INT := IDENT_INT (1); + + PROCEDURE GEN_PROC (I : IN OUT INTEGER) IS + BEGIN + CASE IN_PAR IS + WHEN 0 => I := I + IDENT_INT (2); + WHEN 10 => I := I + IDENT_INT (1); + WHEN -3000 => I := I + IDENT_INT (3); + WHEN OTHERS => I := I + IDENT_INT (4); + END CASE; + + CASE IN_OUT_PAR IS + WHEN 0 => IN_OUT_PAR := IDENT_INT (0); + WHEN 100 => IN_OUT_PAR := IDENT_INT (50); + WHEN -3000 => IN_OUT_PAR := IDENT_INT (-3000); + WHEN OTHERS => IN_OUT_PAR := IDENT_INT (5); + END CASE; + + CASE (IN_PAR) IS + WHEN 0 => I := I + IDENT_INT (2); + WHEN 10 => I := I + IDENT_INT (1); + WHEN -3000 => I := I + IDENT_INT (3); + WHEN OTHERS => I := I + IDENT_INT (4); + END CASE; + + CASE (IN_OUT_PAR) IS + WHEN 0 => IN_OUT_PAR := IDENT_INT (200); + WHEN 50 => IN_OUT_PAR := IDENT_INT (25); + WHEN -3000 => IN_OUT_PAR := IDENT_INT (300); + WHEN OTHERS => IN_OUT_PAR := IDENT_INT (400); + END CASE; + + END GEN_PROC; + + PROCEDURE P IS NEW GEN_PROC (IN_VAR, IN_OUT_VAR); + +BEGIN + TEST ("C54A13B", "CHECK THAT IF A CASE EXPRESSION IS A " & + "GENERIC 'IN' OR 'IN OUT' PARAMETER WITH A " & + "NON-STATIC SUBTYPE OR ONE OF " & + "THESE IN PARENTHESES, THEN ANY VALUE OF " & + "THE EXPRESSION'S BASE TYPE MAY APPEAR AS " & + "A CHOICE"); + + P (CHECK_VAR); + + IF NOT EQUAL (CHECK_VAR, IDENT_INT(3)) THEN + FAILED ("INCORRECT CHOICES MADE FOR IN PARAMETER IN CASE"); + END IF; + + IF NOT EQUAL (IN_OUT_VAR, IDENT_INT(25)) THEN + FAILED ("INCORRECT CHOICESMADE FOR IN OUT PARAMETER IN CASE"); + END IF; + + RESULT; +END C54A13B; diff --git a/gcc/testsuite/ada/acats/tests/c5/c54a13c.ada b/gcc/testsuite/ada/acats/tests/c5/c54a13c.ada new file mode 100644 index 000000000..f093a44b5 --- /dev/null +++ b/gcc/testsuite/ada/acats/tests/c5/c54a13c.ada @@ -0,0 +1,104 @@ +-- C54A13C.ADA + +-- Grant of Unlimited Rights +-- +-- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687, +-- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained +-- unlimited rights in the software and documentation contained herein. +-- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making +-- this public release, the Government intends to confer upon all +-- recipients unlimited rights equal to those held by the Government. +-- These rights include rights to use, duplicate, release or disclose the +-- released technical data and computer software in whole or in part, in +-- any manner and for any purpose whatsoever, and to have or permit others +-- to do so. +-- +-- DISCLAIMER +-- +-- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR +-- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED +-- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE +-- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE +-- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A +-- PARTICULAR PURPOSE OF SAID MATERIAL. +--* +-- OBJECTIVE: +-- CHECK THAT IF A CASE EXPRESSION IS A QUALIFIED EXPRESSION, A +-- TYPE CONVERSION, OR ONE OF THESE IN PARENTHESES, AND ITS +-- SUBTYPE IS NONSTATIC, THEN ANY VALUE OF THE EXPRESSION'S +-- BASE TYPE MAY APPEAR AS A CHOICE. + +-- HISTORY: +-- BCB 07/13/88 CREATED ORIGINAL TEST. + +WITH REPORT; USE REPORT; + +PROCEDURE C54A13C IS + + L : INTEGER := 1; + R : INTEGER := 100; + + SUBTYPE INT IS INTEGER RANGE L .. R; + + A : INT := 50; + + B : INTEGER := 50; + + C : INTEGER; + +BEGIN + TEST ("C54A13C", "CHECK THAT IF A CASE EXPRESSION IS A " & + "QUALIFIED EXPRESSION, A TYPE CONVERSION, " & + "OR ONE OF THESE IN PARENTHESES, AND ITS " & + "SUBTYPE IS NONSTATIC, THEN ANY VALUE OF THE " & + "EXPRESSION'S BASE TYPE MAY APPEAR AS A CHOICE"); + + CASE INT'(A) IS + WHEN 0 => C := IDENT_INT (5); + WHEN 50 => C := IDENT_INT (10); + WHEN -3000 => C := IDENT_INT (15); + WHEN OTHERS => C := IDENT_INT (20); + END CASE; + + IF C /= IDENT_INT (10) THEN + FAILED ("INCORRECT CHOICE MADE FOR QUALIFIED EXPRESSION IN " & + "CASE"); + END IF; + + CASE INT(B) IS + WHEN 0 => C := IDENT_INT (5); + WHEN 50 => C := IDENT_INT (10); + WHEN -3000 => C := IDENT_INT (15); + WHEN OTHERS => C := IDENT_INT (20); + END CASE; + + IF C /= IDENT_INT (10) THEN + FAILED ("INCORRECT CHOICE MADE FOR TYPE CONVERSION IN CASE"); + END IF; + + CASE (INT'(A)) IS + WHEN 0 => C := IDENT_INT (5); + WHEN 50 => C := IDENT_INT (10); + WHEN -3000 => C := IDENT_INT (15); + WHEN OTHERS => C := IDENT_INT (20); + END CASE; + + IF C /= IDENT_INT (10) THEN + FAILED ("INCORRECT CHOICE MADE FOR QUALIFIED EXPRESSION IN " & + "PARENTHESES IN CASE"); + END IF; + + CASE (INT(B)) IS + WHEN 0 => C := IDENT_INT (5); + WHEN 50 => C := IDENT_INT (10); + WHEN -3000 => C := IDENT_INT (15); + WHEN OTHERS => C := IDENT_INT (20); + END CASE; + + IF C /= IDENT_INT (10) THEN + FAILED ("INCORRECT CHOICE MADE FOR TYPE CONVERSION IN " & + "PARENTHESES IN CASE"); + END IF; + + RESULT; +END C54A13C; diff --git a/gcc/testsuite/ada/acats/tests/c5/c54a13d.ada b/gcc/testsuite/ada/acats/tests/c5/c54a13d.ada new file mode 100644 index 000000000..9c71bd106 --- /dev/null +++ b/gcc/testsuite/ada/acats/tests/c5/c54a13d.ada @@ -0,0 +1,138 @@ +-- C54A13D.ADA + +-- Grant of Unlimited Rights +-- +-- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687, +-- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained +-- unlimited rights in the software and documentation contained herein. +-- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making +-- this public release, the Government intends to confer upon all +-- recipients unlimited rights equal to those held by the Government. +-- These rights include rights to use, duplicate, release or disclose the +-- released technical data and computer software in whole or in part, in +-- any manner and for any purpose whatsoever, and to have or permit others +-- to do so. +-- +-- DISCLAIMER +-- +-- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR +-- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED +-- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE +-- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE +-- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A +-- PARTICULAR PURPOSE OF SAID MATERIAL. +--* +-- OBJECTIVE: +-- CHECK THAT IF A CASE EXPRESSION IS A FUNCTION INVOCATION, +-- ATTRIBUTE, STATIC EXPRESSION, OR ONE OF THESE IN PARENTHESES, +-- THEN ANY VALUE OF THE EXPRESSION'S BASE TYPE MAY APPEAR AS A +-- CHOICE. + +-- HISTORY: +-- BCB 07/19/88 CREATED ORIGINAL TEST. +-- PWN 02/02/95 REMOVED INCONSISTENCIES WITH ADA 9X. +-- GJD 11/15/95 REMOVED ADA 95 INCOMPATIBLE ALTERNATIVE IN FIRST CASE. + +WITH REPORT; USE REPORT; + +PROCEDURE C54A13D IS + + SUBTYPE INT IS INTEGER RANGE -100 .. 100; + + CONS : CONSTANT INT := 0; + + C : INT; + + TYPE ENUM IS (ONE, TWO, THREE, FOUR, FIVE, SIX); + + SUBTYPE SUBENUM IS ENUM RANGE THREE .. FOUR; + + FUNCTION FUNC RETURN INT IS + BEGIN + RETURN 0; + END FUNC; + +BEGIN + TEST ("C54A13D", "CHECK THAT IF A CASE EXPRESSION IS A FUNCTION " & + "INVOCATION, ATTRIBUTE, STATIC EXPRESSION, OR " & + "ONE OF THESE IN PARENTHESES, THEN ANY VALUE " & + "OF THE EXPRESSION'S BASE TYPE MAY APPEAR AS " & + "A CHOICE"); + + CASE FUNC IS + WHEN 0 => C := IDENT_INT (5); + WHEN 100 => C := IDENT_INT (10); + WHEN OTHERS => C := IDENT_INT (20); + END CASE; + + IF NOT EQUAL (C,5) THEN + FAILED ("IMPROPER CHOICE FOR CASE EXPRESSION WHICH IS A " & + "FUNCTION INVOCATION - 1"); + END IF; + + CASE (FUNC) IS + WHEN 0 => C := IDENT_INT (25); + WHEN 100 => C := IDENT_INT (50); + WHEN -3000 => C := IDENT_INT (75); + WHEN OTHERS => C := IDENT_INT (90); + END CASE; + + IF NOT EQUAL (C,25) THEN + FAILED ("IMPROPER CHOICE FOR CASE EXPRESSION WHICH IS A " & + "FUNCTION INVOCATION - 2"); + END IF; + + CASE SUBENUM'FIRST IS + WHEN ONE => C := IDENT_INT (100); + WHEN TWO => C := IDENT_INT (99); + WHEN THREE => C := IDENT_INT (98); + WHEN FOUR => C := IDENT_INT (97); + WHEN FIVE => C := IDENT_INT (96); + WHEN SIX => C := IDENT_INT (95); + END CASE; + + IF NOT EQUAL (C,98) THEN + FAILED ("IMPROPER CHOICE FOR CASE EXPRESSION WHICH IS AN " & + "ATTRIBUTE - 1"); + END IF; + + CASE (SUBENUM'FIRST) IS + WHEN ONE => C := IDENT_INT (90); + WHEN TWO => C := IDENT_INT (89); + WHEN THREE => C := IDENT_INT (88); + WHEN FOUR => C := IDENT_INT (87); + WHEN FIVE => C := IDENT_INT (86); + WHEN SIX => C := IDENT_INT (85); + END CASE; + + IF NOT EQUAL (C,88) THEN + FAILED ("IMPROPER CHOICE FOR CASE EXPRESSION WHICH IS AN " & + "ATTRIBUTE - 2"); + END IF; + + CASE CONS * 1 IS + WHEN 0 => C := IDENT_INT (1); + WHEN 100 => C := IDENT_INT (2); + WHEN -3000 => C := IDENT_INT (3); + WHEN OTHERS => C := IDENT_INT (4); + END CASE; + + IF NOT EQUAL (C,1) THEN + FAILED ("IMPROPER CHOICE FOR CASE EXPRESSION WHICH IS A " & + "STATIC EXPRESSION - 1"); + END IF; + + CASE (CONS * 1) IS + WHEN 0 => C := IDENT_INT (10); + WHEN 100 => C := IDENT_INT (20); + WHEN -3000 => C := IDENT_INT (30); + WHEN OTHERS => C := IDENT_INT (40); + END CASE; + + IF NOT EQUAL (C,10) THEN + FAILED ("IMPROPER CHOICE FOR CASE EXPRESSION WHICH IS A " & + "STATIC EXPRESSION - 2"); + END IF; + + RESULT; +END C54A13D; diff --git a/gcc/testsuite/ada/acats/tests/c5/c54a22a.ada b/gcc/testsuite/ada/acats/tests/c5/c54a22a.ada new file mode 100644 index 000000000..4f6ab69d3 --- /dev/null +++ b/gcc/testsuite/ada/acats/tests/c5/c54a22a.ada @@ -0,0 +1,68 @@ +-- C54A22A.ADA + +-- Grant of Unlimited Rights +-- +-- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687, +-- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained +-- unlimited rights in the software and documentation contained herein. +-- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making +-- this public release, the Government intends to confer upon all +-- recipients unlimited rights equal to those held by the Government. +-- These rights include rights to use, duplicate, release or disclose the +-- released technical data and computer software in whole or in part, in +-- any manner and for any purpose whatsoever, and to have or permit others +-- to do so. +-- +-- DISCLAIMER +-- +-- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR +-- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED +-- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF 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 ALL FORMS OF CHOICE IN CASE CHOICES. + +-- DAT 1/29/81 +-- SPS 1/21/83 + +WITH REPORT; +PROCEDURE C54A22A IS + + USE REPORT; + + TYPE T IS RANGE 1 .. 10; + C5 : CONSTANT T := 5; + SUBTYPE S1 IS T RANGE 1 .. 5; + SUBTYPE S2 IS T RANGE C5 + 1 .. 7; + SUBTYPE SN IS T RANGE C5 + 4 .. C5 - 4 + 7; -- NULL RANGE. + SUBTYPE S10 IS T RANGE C5 + 5 .. T'LAST; + +BEGIN + TEST ("C54A22A", "CHECK ALL FORMS OF CASE CHOICES"); + + CASE T'(C5 + 3) IS + WHEN SN -- 9..8 + | S1 RANGE 1 .. 0 -- 1..0 + | S2 RANGE C5 + 2 .. C5 + 1 -- 7..6 + | 3 .. 2 -- 3..2 + => FAILED ("WRONG CASE 1"); + + WHEN S1 RANGE 4 .. C5 -- 4..5 + | S1 RANGE C5 - 4 .. C5 / 2 -- 1..2 + | 3 .. 1 + C5 MOD 3 -- 3..3 + | SN -- 9..8 + | S1 RANGE 5 .. C5 - 1 -- 5..4 + | 6 .. 7 -- 6..7 + | S10 -- 10..10 + | 9 -- 9 + | S10 RANGE 10 .. 9 => -- 10..9 + FAILED ("WRONG CASE 2"); + + WHEN C5 + C5 - 2 .. 8 -- 8 + => NULL; + END CASE; + + RESULT; +END C54A22A; diff --git a/gcc/testsuite/ada/acats/tests/c5/c54a23a.ada b/gcc/testsuite/ada/acats/tests/c5/c54a23a.ada new file mode 100644 index 000000000..7acaa5e65 --- /dev/null +++ b/gcc/testsuite/ada/acats/tests/c5/c54a23a.ada @@ -0,0 +1,49 @@ +-- C54A23A.ADA + +-- Grant of Unlimited Rights +-- +-- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687, +-- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained +-- unlimited rights in the software and documentation contained herein. +-- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making +-- this public release, the Government intends to confer upon all +-- recipients unlimited rights equal to those held by the Government. +-- These rights include rights to use, duplicate, release or disclose the +-- released technical data and computer software in whole or in part, in +-- any manner and for any purpose whatsoever, and to have or permit others +-- to do so. +-- +-- DISCLAIMER +-- +-- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR +-- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED +-- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF 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 CASE CHOICES MAY BE CONSTANT NAMES + +-- DAT 3/18/81 +-- SPS 4/7/82 + +WITH REPORT; USE REPORT; + +PROCEDURE C54A23A IS + + C1 : CONSTANT INTEGER := 1; + C2 : CONSTANT INTEGER := 2; + C3 : CONSTANT INTEGER := 3; + +BEGIN + TEST ("C54A23A", "CASE CHOICES MAY BE CONSTANTS"); + + CASE IDENT_INT (C3) IS + WHEN C1 | C2 + => FAILED ("WRONG CASE CHOICE 1"); + WHEN 3 => NULL; + WHEN OTHERS => FAILED ("WRONG CASE CHOICE 2"); + END CASE; + + RESULT; +END C54A23A; diff --git a/gcc/testsuite/ada/acats/tests/c5/c54a24a.ada b/gcc/testsuite/ada/acats/tests/c5/c54a24a.ada new file mode 100644 index 000000000..edac9de5f --- /dev/null +++ b/gcc/testsuite/ada/acats/tests/c5/c54a24a.ada @@ -0,0 +1,63 @@ +-- C54A24A.ADA + +-- Grant of Unlimited Rights +-- +-- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687, +-- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained +-- unlimited rights in the software and documentation contained herein. +-- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making +-- this public release, the Government intends to confer upon all +-- recipients unlimited rights equal to those held by the Government. +-- These rights include rights to use, duplicate, release or disclose the +-- released technical data and computer software in whole or in part, in +-- any manner and for any purpose whatsoever, and to have or permit others +-- to do so. +-- +-- DISCLAIMER +-- +-- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR +-- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED +-- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF 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 NULL SUBRANGE CHOICES MAY OCCUR IN CASE STATEMENT, WITH +-- OUT-OF-BOUNDS RANGE BOUNDS, AND WHERE VACUOUS CHOICES ARE NULL. +-- CHECK THAT AN UNNEEDED OTHERS CHOICE IS PERMITTED. + +-- DAT 1/29/81 +-- JBG 8/21/83 + +WITH REPORT; +PROCEDURE C54A24A IS + + USE REPORT; + + TYPE T IS RANGE 1 .. 1010; + SUBTYPE ST IS T RANGE 5 .. 7; + + V : ST := 6; + +BEGIN + TEST ("C54A24A", "CHECK NULL CASE SUBRANGE CHOICES, WITH " & + "OUTRAGEOUS BOUNDS"); + + CASE V IS + WHEN -1000 .. -1010 => NULL; + WHEN T RANGE -5 .. -6 => NULL; + WHEN 12 .. 11 | ST RANGE 1000 .. 99 => NULL; + WHEN ST RANGE -99 .. -999 => NULL; + WHEN ST RANGE 6 .. 6 => V := V - 1; + WHEN T RANGE ST'BASE'LAST .. ST'BASE'FIRST => NULL; + WHEN 5 | 7 => NULL; + WHEN ST RANGE T'BASE'LAST .. T'BASE'FIRST => NULL; + WHEN T'BASE'LAST .. T'BASE'FIRST => NULL; + WHEN OTHERS => V := V + 1; + END CASE; + IF V /= 5 THEN + FAILED ("IMPROPER CASE EXECUTION"); + END IF; + + RESULT; +END C54A24A; diff --git a/gcc/testsuite/ada/acats/tests/c5/c54a24b.ada b/gcc/testsuite/ada/acats/tests/c5/c54a24b.ada new file mode 100644 index 000000000..4515e93ca --- /dev/null +++ b/gcc/testsuite/ada/acats/tests/c5/c54a24b.ada @@ -0,0 +1,58 @@ +-- C54A24B.ADA + +-- Grant of Unlimited Rights +-- +-- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687, +-- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained +-- unlimited rights in the software and documentation contained herein. +-- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making +-- this public release, the Government intends to confer upon all +-- recipients unlimited rights equal to those held by the Government. +-- These rights include rights to use, duplicate, release or disclose the +-- released technical data and computer software in whole or in part, in +-- any manner and for any purpose whatsoever, and to have or permit others +-- to do so. +-- +-- DISCLAIMER +-- +-- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR +-- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED +-- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF 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 NULL SUBTYPE RANGES ARE ACCEPTABLE CASE CHOICES, +-- WHERE THE BOUNDS ARE BOTH OUT OF THE SUBRANGE'S RANGE, AND +-- WHERE VACUOUS CHOICES HAVE NON-NULL STATEMENT SEQUENCES. +-- CHECK THAT AN UNNEEDED OTHERS CLAUSE IS PERMITTED. + +-- HISTORY: +-- DAT 01/29/81 CREATED ORIGINAL TEST. +-- DHH 10/20/87 SHORTENED LINES CONTAINING MORE THAN 72 CHARACTERS. + +WITH REPORT; +PROCEDURE C54A24B IS + + USE REPORT; + + TYPE C IS NEW CHARACTER RANGE 'A' .. 'D'; + X : C := 'B'; + +BEGIN + TEST ("C54A24B", "NULL CASE CHOICE SUBRANGES WITH VALUES " & + "OUTSIDE SUBRANGE"); + + CASE X IS + WHEN C RANGE C'BASE'LAST .. C'BASE'FIRST + | C RANGE 'Z' .. ' ' => X := 'A'; + WHEN C => NULL; + WHEN OTHERS => X := 'C'; + END CASE; + IF X /= 'B' THEN + FAILED ("WRONG CASE EXECUTION"); + END IF; + + RESULT; +END C54A24B; diff --git a/gcc/testsuite/ada/acats/tests/c5/c54a42a.ada b/gcc/testsuite/ada/acats/tests/c5/c54a42a.ada new file mode 100644 index 000000000..b6babb0d2 --- /dev/null +++ b/gcc/testsuite/ada/acats/tests/c5/c54a42a.ada @@ -0,0 +1,173 @@ +-- C54A42A.ADA + +-- Grant of Unlimited Rights +-- +-- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687, +-- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained +-- unlimited rights in the software and documentation contained herein. +-- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making +-- this public release, the Government intends to confer upon all +-- recipients unlimited rights equal to those held by the Government. +-- These rights include rights to use, duplicate, release or disclose the +-- released technical data and computer software in whole or in part, in +-- any manner and for any purpose whatsoever, and to have or permit others +-- to do so. +-- +-- DISCLAIMER +-- +-- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR +-- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED +-- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF 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 CASE_STATEMENT MAY HANDLE A LARGE NUMBER OF +-- POTENTIAL VALUES GROUPED INTO A SMALL NUMBER OF ALTERNATIVES +-- AND THAT EACH TIME THE APPROPRIATE ALTERNATIVE IS EXECUTED. + +-- (OPTIMIZATION TEST.) + + +-- RM 03/24/81 +-- PWN 11/30/94 SUBTYPE QUALIFIED LITERALS FOR ADA 9X. + + +WITH REPORT; +PROCEDURE C54A42A IS + + USE REPORT ; + +BEGIN + + TEST( "C54A42A" , "TEST THAT A CASE_STATEMENT HANDLES CORRECTLY" & + " A LARGE NUMBER OF POTENTIAL VALUES GROUPED" & + " INTO A SMALL NUMBER OF ALTERNATIVES" ); + + DECLARE + + STATCON : CONSTANT CHARACTER := 'B' ; + STATVAR : CHARACTER := 'Q' ; + DYNCON : CONSTANT CHARACTER := IDENT_CHAR( 'Y' ); + DYNVAR : CHARACTER := IDENT_CHAR( 'Z' ); + + BEGIN + + CASE CHARACTER'('A') IS + WHEN ASCII.NUL .. 'A' => NULL ; + WHEN 'B' => FAILED( "WRONG ALTERN. A2" ); + WHEN 'P' => FAILED( "WRONG ALTERN. A3" ); + WHEN 'Y' => FAILED( "WRONG ALTERN. A4" ); + WHEN 'Z' .. ASCII.DEL => FAILED( "WRONG ALTERN. A5" ); + WHEN OTHERS => FAILED( "WRONG ALTERN. A6" ); + END CASE; + + CASE STATCON IS + WHEN ASCII.NUL .. 'A' => FAILED( "WRONG ALTERN. B1" ); + WHEN 'B' => NULL ; + WHEN 'P' => FAILED( "WRONG ALTERN. B3" ); + WHEN 'Y' => FAILED( "WRONG ALTERN. B4" ); + WHEN 'Z' .. ASCII.DEL => FAILED( "WRONG ALTERN. B5" ); + WHEN OTHERS => FAILED( "WRONG ALTERN. B6" ); + END CASE; + + CASE STATVAR IS + WHEN ASCII.NUL .. 'A' => FAILED( "WRONG ALTERN. C1" ); + WHEN 'B' => FAILED( "WRONG ALTERN. C2" ); + WHEN 'P' => FAILED( "WRONG ALTERN. C3" ); + WHEN 'Y' => FAILED( "WRONG ALTERN. C4" ); + WHEN 'Z' .. ASCII.DEL => FAILED( "WRONG ALTERN. C5" ); + WHEN OTHERS => NULL ; + END CASE; + + CASE DYNCON IS + WHEN ASCII.NUL .. 'A' => FAILED( "WRONG ALTERN. D1" ); + WHEN 'B' => FAILED( "WRONG ALTERN. D2" ); + WHEN 'P' => FAILED( "WRONG ALTERN. D3" ); + WHEN 'Y' => NULL ; + WHEN 'Z' .. ASCII.DEL => FAILED( "WRONG ALTERN. D5" ); + WHEN OTHERS => FAILED( "WRONG ALTERN. D6" ); + END CASE; + + CASE DYNVAR IS + WHEN ASCII.NUL .. 'A' => FAILED( "WRONG ALTERN. E1" ); + WHEN 'B' => FAILED( "WRONG ALTERN. E2" ); + WHEN 'P' => FAILED( "WRONG ALTERN. E3" ); + WHEN 'Y' => FAILED( "WRONG ALTERN. E4" ); + WHEN 'Z' .. ASCII.DEL => NULL ; + WHEN OTHERS => FAILED( "WRONG ALTERN. E6" ); + END CASE; + + END ; + + + DECLARE + + NUMBER : CONSTANT := -100 ; + LITEXPR : CONSTANT := 0 * NUMBER + 16 ; + STATCON : CONSTANT INTEGER := +100 ; + DYNVAR : INTEGER := IDENT_INT( 102 ) ; + DYNCON : CONSTANT INTEGER := IDENT_INT( 17 ) ; + + BEGIN + + CASE INTEGER'(-102) IS + WHEN INTEGER'FIRST..-101 => NULL ; + WHEN -100 => FAILED("WRONG ALTERN. F2"); + WHEN 17 => FAILED("WRONG ALTERN. F2"); + WHEN 100 => FAILED("WRONG ALTERN. F4"); + WHEN 101..INTEGER'LAST => FAILED("WRONG ALTERN. F5"); + WHEN OTHERS => FAILED("WRONG ALTERN. F6"); + END CASE; + + CASE IDENT_INT(NUMBER) IS + WHEN INTEGER'FIRST..-101 => FAILED("WRONG ALTERN. G1"); + WHEN -100 => NULL ; + WHEN 17 => FAILED("WRONG ALTERN. G3"); + WHEN 100 => FAILED("WRONG ALTERN. G4"); + WHEN 101..INTEGER'LAST => FAILED("WRONG ALTERN. G5"); + WHEN OTHERS => FAILED("WRONG ALTERN. G6"); + END CASE; + + CASE IDENT_INT(LITEXPR) IS + WHEN INTEGER'FIRST..-101 => FAILED("WRONG ALTERN. H1"); + WHEN -100 => FAILED("WRONG ALTERN. H2"); + WHEN 17 => FAILED("WRONG ALTERN. H3"); + WHEN 100 => FAILED("WRONG ALTERN. H4"); + WHEN 101..INTEGER'LAST => FAILED("WRONG ALTERN. H5"); + WHEN OTHERS => NULL ; + END CASE; + + CASE STATCON IS + WHEN INTEGER'FIRST..-101 => FAILED("WRONG ALTERN. I1"); + WHEN -100 => FAILED("WRONG ALTERN. I2"); + WHEN 17 => FAILED("WRONG ALTERN. I3"); + WHEN 100 => NULL ; + WHEN 101..INTEGER'LAST => FAILED("WRONG ALTERN. I5"); + WHEN OTHERS => FAILED("WRONG ALTERN. I6"); + END CASE; + + CASE DYNVAR IS + WHEN INTEGER'FIRST..-101 => FAILED("WRONG ALTERN. J1"); + WHEN -100 => FAILED("WRONG ALTERN. J2"); + WHEN 17 => FAILED("WRONG ALTERN. J3"); + WHEN 100 => FAILED("WRONG ALTERN. J4"); + WHEN 101..INTEGER'LAST => NULL ; + WHEN OTHERS => FAILED("WRONG ALTERN. J6"); + END CASE; + + CASE DYNCON IS + WHEN INTEGER'FIRST..-101 => FAILED("WRONG ALTERN. K1"); + WHEN -100 => FAILED("WRONG ALTERN. K2"); + WHEN 17 => NULL ; + WHEN 100 => FAILED("WRONG ALTERN. K4"); + WHEN 101..INTEGER'LAST => FAILED("WRONG ALTERN. K5"); + WHEN OTHERS => FAILED("WRONG ALTERN. K6"); + END CASE; + END ; + + + RESULT ; + + +END C54A42A ; diff --git a/gcc/testsuite/ada/acats/tests/c5/c54a42b.ada b/gcc/testsuite/ada/acats/tests/c5/c54a42b.ada new file mode 100644 index 000000000..bcf1dcc90 --- /dev/null +++ b/gcc/testsuite/ada/acats/tests/c5/c54a42b.ada @@ -0,0 +1,173 @@ +-- C54A42B.ADA + +-- Grant of Unlimited Rights +-- +-- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687, +-- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained +-- unlimited rights in the software and documentation contained herein. +-- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making +-- this public release, the Government intends to confer upon all +-- recipients unlimited rights equal to those held by the Government. +-- These rights include rights to use, duplicate, release or disclose the +-- released technical data and computer software in whole or in part, in +-- any manner and for any purpose whatsoever, and to have or permit others +-- to do so. +-- +-- DISCLAIMER +-- +-- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR +-- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED +-- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF 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 CASE_STATEMENT CORRECTLY HANDLES A SMALL RANGE OF +-- POTENTIAL VALUES GROUPED INTO A SMALL NUMBER OF ALTERNATIVES. + +-- (OPTIMIZATION TEST -- JUMP TABLE.) + + +-- RM 03/26/81 +-- PWN 11/30/94 SUBTYPE QUALIFIED LITERALS FOR ADA 9X. + + +WITH REPORT; +PROCEDURE C54A42B IS + + USE REPORT ; + +BEGIN + + TEST( "C54A42B" , "TEST THAT A CASE_STATEMENT HANDLES CORRECTLY" & + " A SMALL NUMBER OF POTENTIAL VALUES GROUPED" & + " INTO A SMALL NUMBER OF ALTERNATIVES" ); + + DECLARE + + STATCON : CONSTANT CHARACTER RANGE 'A'..'K' := 'J' ; + STATVAR : CHARACTER RANGE 'A'..'K' := 'A' ; + DYNCON : CONSTANT CHARACTER RANGE 'A'..'K' :=IDENT_CHAR('K'); + DYNVAR : CHARACTER RANGE 'A'..'K' :=IDENT_CHAR('G'); + + BEGIN + + CASE STATVAR IS + WHEN 'B' | 'E' => FAILED( "WRONG ALTERNATIVE A1" ); + WHEN 'J' | 'C' => FAILED( "WRONG ALTERNATIVE A2" ); + WHEN 'F' => FAILED( "WRONG ALTERNATIVE A3" ); + WHEN 'D' | 'H'..'I' => FAILED( "WRONG ALTERNATIVE A4" ); + WHEN 'G' => FAILED( "WRONG ALTERNATIVE A5" ); + WHEN OTHERS => NULL ; + END CASE; + + CASE CHARACTER'('B') IS + WHEN 'B' | 'E' => NULL ; + WHEN 'J' | 'C' => FAILED( "WRONG ALTERNATIVE B2" ); + WHEN 'F' => FAILED( "WRONG ALTERNATIVE B3" ); + WHEN 'D' | 'H'..'I' => FAILED( "WRONG ALTERNATIVE B4" ); + WHEN 'G' => FAILED( "WRONG ALTERNATIVE B5" ); + WHEN OTHERS => FAILED( "WRONG ALTERNATIVE B6" ); + END CASE; + + CASE DYNVAR IS + WHEN 'B' | 'E' => FAILED( "WRONG ALTERNATIVE C1" ); + WHEN 'J' | 'C' => FAILED( "WRONG ALTERNATIVE C2" ); + WHEN 'F' => FAILED( "WRONG ALTERNATIVE C3" ); + WHEN 'D' | 'H'..'I' => FAILED( "WRONG ALTERNATIVE C4" ); + WHEN 'G' => NULL ; + WHEN OTHERS => FAILED( "WRONG ALTERNATIVE C6" ); + END CASE; + + CASE IDENT_CHAR(STATCON) IS + WHEN 'B' | 'E' => FAILED( "WRONG ALTERNATIVE D1" ); + WHEN 'J' | 'C' => NULL ; + WHEN 'F' => FAILED( "WRONG ALTERNATIVE D3" ); + WHEN 'D' | 'H'..'I' => FAILED( "WRONG ALTERNATIVE D4" ); + WHEN 'G' => FAILED( "WRONG ALTERNATIVE D5" ); + WHEN OTHERS => FAILED( "WRONG ALTERNATIVE D6" ); + END CASE; + + CASE DYNCON IS + WHEN 'B' | 'E' => FAILED( "WRONG ALTERNATIVE E1" ); + WHEN 'J' | 'C' => FAILED( "WRONG ALTERNATIVE E2" ); + WHEN 'F' => FAILED( "WRONG ALTERNATIVE E3" ); + WHEN 'D' | 'H'..'I' => FAILED( "WRONG ALTERNATIVE E4" ); + WHEN 'G' => FAILED( "WRONG ALTERNATIVE E5" ); + WHEN OTHERS => NULL ; + END CASE; + + END ; + + + DECLARE + + NUMBER : CONSTANT := 1 ; + LITEXPR : CONSTANT := NUMBER + 5 ; + STATCON : CONSTANT INTEGER RANGE 0..10 := 9 ; + DYNVAR : INTEGER RANGE 0..10 := IDENT_INT( 10 ); + DYNCON : CONSTANT INTEGER RANGE 0..10 := IDENT_INT( 2 ); + + BEGIN + + CASE INTEGER'(0) IS + WHEN 1 | 4 => FAILED("WRONG ALTERNATIVE F1"); + WHEN 9 | 2 => FAILED("WRONG ALTERNATIVE F2"); + WHEN 5 => FAILED("WRONG ALTERNATIVE F3"); + WHEN 3 | 7..8 => FAILED("WRONG ALTERNATIVE F4"); + WHEN 6 => FAILED("WRONG ALTERNATIVE F5"); + WHEN OTHERS => NULL ; + END CASE; + + CASE INTEGER'(NUMBER) IS + WHEN 1 | 4 => NULL ; + WHEN 9 | 2 => FAILED("WRONG ALTERNATIVE G2"); + WHEN 5 => FAILED("WRONG ALTERNATIVE G3"); + WHEN 3 | 7..8 => FAILED("WRONG ALTERNATIVE G4"); + WHEN 6 => FAILED("WRONG ALTERNATIVE G5"); + WHEN OTHERS => FAILED("WRONG ALTERNATIVE G6"); + END CASE; + + CASE IDENT_INT(LITEXPR) IS + WHEN 1 | 4 => FAILED("WRONG ALTERNATIVE H1"); + WHEN 9 | 2 => FAILED("WRONG ALTERNATIVE H2"); + WHEN 5 => FAILED("WRONG ALTERNATIVE H3"); + WHEN 3 | 7..8 => FAILED("WRONG ALTERNATIVE H4"); + WHEN 6 => NULL ; + WHEN OTHERS => FAILED("WRONG ALTERNATIVE H6"); + END CASE; + + CASE STATCON IS + WHEN 1 | 4 => FAILED("WRONG ALTERNATIVE I1"); + WHEN 9 | 2 => NULL ; + WHEN 5 => FAILED("WRONG ALTERNATIVE I3"); + WHEN 3 | 7..8 => FAILED("WRONG ALTERNATIVE I4"); + WHEN 6 => FAILED("WRONG ALTERNATIVE I5"); + WHEN OTHERS => FAILED("WRONG ALTERNATIVE I6"); + END CASE; + + CASE DYNVAR IS + WHEN 1 | 4 => FAILED("WRONG ALTERNATIVE J1"); + WHEN 9 | 2 => FAILED("WRONG ALTERNATIVE J2"); + WHEN 5 => FAILED("WRONG ALTERNATIVE J3"); + WHEN 3 | 7..8 => FAILED("WRONG ALTERNATIVE J4"); + WHEN 6 => FAILED("WRONG ALTERNATIVE J5"); + WHEN OTHERS => NULL ; + END CASE; + + CASE DYNCON IS + WHEN 1 | 4 => FAILED("WRONG ALTERNATIVE K1"); + WHEN 9 | 2 => NULL ; + WHEN 5 => FAILED("WRONG ALTERNATIVE K3"); + WHEN 3 | 7..8 => FAILED("WRONG ALTERNATIVE K4"); + WHEN 6 => FAILED("WRONG ALTERNATIVE K5"); + WHEN OTHERS => FAILED("WRONG ALTERNATIVE K6"); + END CASE; + + END ; + + + RESULT ; + + +END C54A42B ; diff --git a/gcc/testsuite/ada/acats/tests/c5/c54a42c.ada b/gcc/testsuite/ada/acats/tests/c5/c54a42c.ada new file mode 100644 index 000000000..79a397976 --- /dev/null +++ b/gcc/testsuite/ada/acats/tests/c5/c54a42c.ada @@ -0,0 +1,123 @@ +-- C54A42C.ADA + +-- Grant of Unlimited Rights +-- +-- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687, +-- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained +-- unlimited rights in the software and documentation contained herein. +-- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making +-- this public release, the Government intends to confer upon all +-- recipients unlimited rights equal to those held by the Government. +-- These rights include rights to use, duplicate, release or disclose the +-- released technical data and computer software in whole or in part, in +-- any manner and for any purpose whatsoever, and to have or permit others +-- to do so. +-- +-- DISCLAIMER +-- +-- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR +-- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED +-- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF 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 CASE_STATEMENT CORRECTLY HANDLES A SPARSE SET OF +-- POTENTIAL VALUES (OF TYPE INTEGER) IN A LARGE RANGE. + +-- (OPTIMIZATION TEST) + + +-- RM 03/26/81 + + +WITH REPORT; +PROCEDURE C54A42C IS + + USE REPORT ; + +BEGIN + + TEST( "C54A42C" , "TEST THAT A CASE_STATEMENT HANDLES CORRECTLY" & + " A SPARSE SET OF POTENTIAL VALUES IN A LARGE" & + " RANGE" ); + + DECLARE + + NUMBER : CONSTANT := 1001 ; + LITEXPR : CONSTANT := NUMBER + 998 ; + STATCON : CONSTANT INTEGER RANGE 1..INTEGER'LAST := 1000 ; + DYNVAR : INTEGER RANGE 1..INTEGER'LAST := + IDENT_INT( INTEGER'LAST-50 ); + DYNCON : CONSTANT INTEGER RANGE 1..INTEGER'LAST := + IDENT_INT( 1000 ); + + BEGIN + + CASE INTEGER'( NUMBER ) IS + WHEN 1 .. 10 => FAILED("WRONG ALTERNATIVE F1"); + WHEN 1000 => FAILED("WRONG ALTERNATIVE F2"); + WHEN 2000 => FAILED("WRONG ALTERNATIVE F3"); + WHEN 4000 .. 4100 => FAILED("WRONG ALTERNATIVE F4"); + WHEN INTEGER'LAST-100 .. + INTEGER'LAST => FAILED("WRONG ALTERNATIVE F5"); + WHEN OTHERS => NULL ; + END CASE; + + CASE IDENT_INT( 10 ) IS + WHEN 1 .. 10 => NULL ; + WHEN 1000 => FAILED("WRONG ALTERNATIVE G2"); + WHEN 2000 => FAILED("WRONG ALTERNATIVE G3"); + WHEN 4000 .. 4100 => FAILED("WRONG ALTERNATIVE G4"); + WHEN INTEGER'LAST -100 .. + INTEGER'LAST => FAILED("WRONG ALTERNATIVE G5"); + WHEN OTHERS => FAILED("WRONG ALTERNATIVE G6"); + END CASE; + + CASE IDENT_INT(LITEXPR) IS + WHEN 1 .. 10 => FAILED("WRONG ALTERNATIVE H1"); + WHEN 1000 => FAILED("WRONG ALTERNATIVE H2"); + WHEN 2000 => FAILED("WRONG ALTERNATIVE H3"); + WHEN 4000 .. 4100 => FAILED("WRONG ALTERNATIVE H4"); + WHEN INTEGER'LAST -100 .. + INTEGER'LAST => FAILED("WRONG ALTERNATIVE H5"); + WHEN OTHERS => NULL ; + END CASE; + + CASE STATCON IS + WHEN 1 .. 10 => FAILED("WRONG ALTERNATIVE I1"); + WHEN 1000 => NULL ; + WHEN 2000 => FAILED("WRONG ALTERNATIVE I3"); + WHEN 4000 .. 4100 => FAILED("WRONG ALTERNATIVE I4"); + WHEN INTEGER'LAST -100 .. + INTEGER'LAST => FAILED("WRONG ALTERNATIVE I5"); + WHEN OTHERS => FAILED("WRONG ALTERNATIVE I6"); + END CASE; + + CASE DYNVAR IS + WHEN 1 .. 10 => FAILED("WRONG ALTERNATIVE J1"); + WHEN 1000 => FAILED("WRONG ALTERNATIVE J2"); + WHEN 2000 => FAILED("WRONG ALTERNATIVE J3"); + WHEN 4000 .. 4100 => FAILED("WRONG ALTERNATIVE J4"); + WHEN INTEGER'LAST -100 .. + INTEGER'LAST => NULL ; + WHEN OTHERS => FAILED("WRONG ALTERNATIVE J6"); + END CASE; + + CASE DYNCON IS + WHEN 1 .. 10 => FAILED("WRONG ALTERNATIVE K1"); + WHEN 1000 => NULL ; + WHEN 2000 => FAILED("WRONG ALTERNATIVE K3"); + WHEN 4000 .. 4100 => FAILED("WRONG ALTERNATIVE K4"); + WHEN INTEGER'LAST -100 .. + INTEGER'LAST => FAILED("WRONG ALTERNATIVE K5"); + WHEN OTHERS => FAILED("WRONG ALTERNATIVE K6"); + END CASE; + + END ; + + + RESULT ; + + +END C54A42C ; diff --git a/gcc/testsuite/ada/acats/tests/c5/c54a42d.ada b/gcc/testsuite/ada/acats/tests/c5/c54a42d.ada new file mode 100644 index 000000000..9394f5c56 --- /dev/null +++ b/gcc/testsuite/ada/acats/tests/c5/c54a42d.ada @@ -0,0 +1,104 @@ +-- C54A42D.ADA + +-- Grant of Unlimited Rights +-- +-- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687, +-- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained +-- unlimited rights in the software and documentation contained herein. +-- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making +-- this public release, the Government intends to confer upon all +-- recipients unlimited rights equal to those held by the Government. +-- These rights include rights to use, duplicate, release or disclose the +-- released technical data and computer software in whole or in part, in +-- any manner and for any purpose whatsoever, and to have or permit others +-- to do so. +-- +-- DISCLAIMER +-- +-- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR +-- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED +-- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF 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 CASE_STATEMENT CORRECTLY HANDLES A FEW ALTERNATIVES +-- COVERING A LARGE RANGE OF INTEGERS. + + +-- (OPTIMIZATION TEST.) + + +-- RM 03/30/81 + + +WITH REPORT; +PROCEDURE C54A42D IS + + USE REPORT ; + +BEGIN + + TEST( "C54A42D" , "TEST THAT A CASE_STATEMENT CORRECTLY HANDLES" & + " A FEW ALTERNATIVES COVERING A LARGE RANGE" & + " OF INTEGERS" ); + + DECLARE + + NUMBER : CONSTANT := 2000 ; + LITEXPR : CONSTANT := NUMBER + 2000 ; + STATCON : CONSTANT INTEGER := 2001 ; + DYNVAR : INTEGER := IDENT_INT( 0 ); + DYNCON : CONSTANT INTEGER := IDENT_INT( 1 ); + + BEGIN + + CASE INTEGER'(-4000) IS + WHEN 1..2000 => FAILED("WRONG ALTERNATIVE F1"); + WHEN INTEGER'FIRST..0=> NULL ; + WHEN 2001 => FAILED("WRONG ALTERNATIVE F3"); + WHEN 2002..INTEGER'LAST=>FAILED("WRONG ALTERNATIVE F4"); + END CASE; + + CASE INTEGER'(NUMBER) IS + WHEN 1..2000 => NULL ; + WHEN INTEGER'FIRST..0=> FAILED("WRONG ALTERNATIVE G2"); + WHEN 2001 => FAILED("WRONG ALTERNATIVE G3"); + WHEN 2002..INTEGER'LAST=>FAILED("WRONG ALTERNATIVE G4"); + END CASE; + + CASE IDENT_INT(LITEXPR) IS + WHEN 1..2000 => FAILED("WRONG ALTERNATIVE H1"); + WHEN INTEGER'FIRST..0=> FAILED("WRONG ALTERNATIVE H2"); + WHEN 2001 => FAILED("WRONG ALTERNATIVE H3"); + WHEN 2002..INTEGER'LAST=>NULL ; + END CASE; + + CASE STATCON IS + WHEN 1..2000 => FAILED("WRONG ALTERNATIVE I1"); + WHEN INTEGER'FIRST..0=> FAILED("WRONG ALTERNATIVE I2"); + WHEN 2001 => NULL ; + WHEN 2002..INTEGER'LAST=>FAILED("WRONG ALTERNATIVE I4"); + END CASE; + + CASE DYNVAR IS + WHEN 1..2000 => FAILED("WRONG ALTERNATIVE J1"); + WHEN INTEGER'FIRST..0=> NULL ; + WHEN 2001 => FAILED("WRONG ALTERNATIVE J3"); + WHEN 2002..INTEGER'LAST=>FAILED("WRONG ALTERNATIVE J4"); + END CASE; + + CASE DYNCON IS + WHEN 1..2000 => NULL ; + WHEN INTEGER'FIRST..0=> FAILED("WRONG ALTERNATIVE K2"); + WHEN 2001 => FAILED("WRONG ALTERNATIVE K3"); + WHEN 2002..INTEGER'LAST=>FAILED("WRONG ALTERNATIVE K4"); + END CASE; + + END ; + + + RESULT ; + + +END C54A42D ; diff --git a/gcc/testsuite/ada/acats/tests/c5/c54a42e.ada b/gcc/testsuite/ada/acats/tests/c5/c54a42e.ada new file mode 100644 index 000000000..fb2216407 --- /dev/null +++ b/gcc/testsuite/ada/acats/tests/c5/c54a42e.ada @@ -0,0 +1,125 @@ +-- C54A42E.ADA + +-- Grant of Unlimited Rights +-- +-- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687, +-- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained +-- unlimited rights in the software and documentation contained herein. +-- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making +-- this public release, the Government intends to confer upon all +-- recipients unlimited rights equal to those held by the Government. +-- These rights include rights to use, duplicate, release or disclose the +-- released technical data and computer software in whole or in part, in +-- any manner and for any purpose whatsoever, and to have or permit others +-- to do so. +-- +-- DISCLAIMER +-- +-- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR +-- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED +-- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF 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 CASE_STATEMENT CORRECTLY HANDLES A SMALL RANGE OF +-- POTENTIAL VALUES OF TYPE INTEGER, SITUATED FAR FROM 0 AND +-- GROUPED INTO A SMALL NUMBER OF ALTERNATIVES. + +-- (OPTIMIZATION TEST -- BIASED JUMP TABLE.) + + +-- RM 03/26/81 + + +WITH REPORT; +PROCEDURE C54A42E IS + + USE REPORT ; + +BEGIN + + TEST( "C54A42E" , "TEST THAT A CASE_STATEMENT HANDLES CORRECTLY" & + " A SMALL, FAR RANGE OF POTENTIAL VALUES OF" & + " TYPE INTEGER" ); + + DECLARE + + NUMBER : CONSTANT := 4001 ; + LITEXPR : CONSTANT := NUMBER + 5 ; + STATCON : CONSTANT INTEGER RANGE 4000..4010 := 4009 ; + DYNVAR : INTEGER RANGE 4000..4010 := + IDENT_INT( 4010 ); + DYNCON : CONSTANT INTEGER RANGE 4000..4010 := + IDENT_INT( 4002 ); + + BEGIN + + CASE INTEGER'(4000) IS + WHEN 4001 | 4004 => FAILED("WRONG ALTERNATIVE F1"); + WHEN 4009 | 4002 => FAILED("WRONG ALTERNATIVE F2"); + WHEN 4005 => FAILED("WRONG ALTERNATIVE F3"); + WHEN 4003 | + 4007..4008 => FAILED("WRONG ALTERNATIVE F4"); + WHEN 4006 => FAILED("WRONG ALTERNATIVE F5"); + WHEN OTHERS => NULL ; + END CASE; + + CASE IDENT_INT(NUMBER) IS + WHEN 4001 | 4004 => NULL ; + WHEN 4009 | 4002 => FAILED("WRONG ALTERNATIVE G2"); + WHEN 4005 => FAILED("WRONG ALTERNATIVE G3"); + WHEN 4003 | + 4007..4008 => FAILED("WRONG ALTERNATIVE G4"); + WHEN 4006 => FAILED("WRONG ALTERNATIVE G5"); + WHEN OTHERS => FAILED("WRONG ALTERNATIVE G6"); + END CASE; + + CASE IDENT_INT(LITEXPR) IS + WHEN 4001 | 4004 => FAILED("WRONG ALTERNATIVE H1"); + WHEN 4009 | 4002 => FAILED("WRONG ALTERNATIVE H2"); + WHEN 4005 => FAILED("WRONG ALTERNATIVE H3"); + WHEN 4003 | + 4007..4008 => FAILED("WRONG ALTERNATIVE H4"); + WHEN 4006 => NULL ; + WHEN OTHERS => FAILED("WRONG ALTERNATIVE H6"); + END CASE; + + CASE STATCON IS + WHEN 4001 | 4004 => FAILED("WRONG ALTERNATIVE I1"); + WHEN 4009 | 4002 => NULL ; + WHEN 4005 => FAILED("WRONG ALTERNATIVE I3"); + WHEN 4003 | + 4007..4008 => FAILED("WRONG ALTERNATIVE I4"); + WHEN 4006 => FAILED("WRONG ALTERNATIVE I5"); + WHEN OTHERS => FAILED("WRONG ALTERNATIVE I6"); + END CASE; + + CASE DYNVAR IS + WHEN 4001 | 4004 => FAILED("WRONG ALTERNATIVE J1"); + WHEN 4009 | 4002 => FAILED("WRONG ALTERNATIVE J2"); + WHEN 4005 => FAILED("WRONG ALTERNATIVE J3"); + WHEN 4003 | + 4007..4008 => FAILED("WRONG ALTERNATIVE J4"); + WHEN 4006 => FAILED("WRONG ALTERNATIVE J5"); + WHEN OTHERS => NULL ; + + END CASE; + + CASE DYNCON IS + WHEN 4001 | 4004 => FAILED("WRONG ALTERNATIVE K1"); + WHEN 4009 | 4002 => NULL ; + WHEN 4005 => FAILED("WRONG ALTERNATIVE K3"); + WHEN 4003 | + 4007..4008 => FAILED("WRONG ALTERNATIVE K4"); + WHEN 4006 => FAILED("WRONG ALTERNATIVE K5"); + WHEN OTHERS => FAILED("WRONG ALTERNATIVE K6"); + END CASE; + + END ; + + + RESULT ; + + +END C54A42E ; diff --git a/gcc/testsuite/ada/acats/tests/c5/c54a42f.ada b/gcc/testsuite/ada/acats/tests/c5/c54a42f.ada new file mode 100644 index 000000000..c321ce8c8 --- /dev/null +++ b/gcc/testsuite/ada/acats/tests/c5/c54a42f.ada @@ -0,0 +1,126 @@ +-- C54A42F.ADA + +-- Grant of Unlimited Rights +-- +-- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687, +-- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained +-- unlimited rights in the software and documentation contained herein. +-- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making +-- this public release, the Government intends to confer upon all +-- recipients unlimited rights equal to those held by the Government. +-- These rights include rights to use, duplicate, release or disclose the +-- released technical data and computer software in whole or in part, in +-- any manner and for any purpose whatsoever, and to have or permit others +-- to do so. +-- +-- DISCLAIMER +-- +-- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR +-- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED +-- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF 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 CASE_STATEMENT CORRECTLY HANDLES SEVERAL SMALL, +-- NON-CONTIGUOUS RANGES OF INTEGERS COVERED BY A SINGLE 'OTHERS' +-- ALTERNATIVE. + + +-- (OPTIMIZATION TEST.) + + +-- RM 03/31/81 + + +WITH REPORT; +PROCEDURE C54A42F IS + + USE REPORT ; + +BEGIN + + TEST( "C54A42F" , "TEST THAT A CASE_STATEMENT CORRECTLY HANDLES" & + " SEVERAL SMALL, NON-CONTIGUOUS ENUMERATION" & + " RANGES COVERED BY A SINGLE 'OTHERS' " & + " ALTERNATIVE" ); + + DECLARE + + TYPE DAY IS (SUN , MON , TUE , WED , THU , FRI , SAT ); + + DYNVAR2 : DAY := MON ; + STATVAR : DAY := TUE ; + STATCON : CONSTANT DAY := WED ; + DYNVAR : DAY := THU ; + DYNCON : CONSTANT DAY := DAY'VAL( IDENT_INT(5) ); -- FRI + + BEGIN + + IF EQUAL(1,289) THEN + DYNVAR := SUN ; + DYNVAR2 := SUN ; + END IF; + + CASE SUN IS -- SUN + WHEN THU => FAILED("WRONG ALTERNATIVE F1"); + WHEN SUN => NULL ; + WHEN SAT => FAILED("WRONG ALTERNATIVE F3"); + WHEN TUE..WED => FAILED("WRONG ALTERNATIVE F4"); + WHEN OTHERS => FAILED("WRONG ALTERNATIVE F5"); + END CASE; + + CASE DYNVAR2 IS -- MON + WHEN THU => FAILED("WRONG ALTERNATIVE G1"); + WHEN SUN => FAILED("WRONG ALTERNATIVE G2"); + WHEN SAT => FAILED("WRONG ALTERNATIVE G3"); + WHEN TUE..WED => FAILED("WRONG ALTERNATIVE G4"); + WHEN OTHERS => NULL ; + END CASE; + + CASE STATVAR IS -- TUE + WHEN THU => FAILED("WRONG ALTERNATIVE H1"); + WHEN SUN => FAILED("WRONG ALTERNATIVE H2"); + WHEN SAT => FAILED("WRONG ALTERNATIVE H3"); + WHEN TUE..WED => NULL ; + WHEN OTHERS => FAILED("WRONG ALTERNATIVE H5"); + END CASE; + + CASE STATCON IS -- WED + WHEN THU => FAILED("WRONG ALTERNATIVE I1"); + WHEN SUN => FAILED("WRONG ALTERNATIVE I2"); + WHEN SAT => FAILED("WRONG ALTERNATIVE I3"); + WHEN TUE..WED => NULL ; + WHEN OTHERS => FAILED("WRONG ALTERNATIVE I5"); + END CASE; + + CASE DYNVAR IS -- THU + WHEN THU => NULL ; + WHEN SUN => FAILED("WRONG ALTERNATIVE J2"); + WHEN SAT => FAILED("WRONG ALTERNATIVE J3"); + WHEN TUE..WED => FAILED("WRONG ALTERNATIVE J4"); + WHEN OTHERS => FAILED("WRONG ALTERNATIVE J5"); + END CASE; + + CASE DYNCON IS -- FRI + WHEN THU => FAILED("WRONG ALTERNATIVE K1"); + WHEN SUN => FAILED("WRONG ALTERNATIVE K2"); + WHEN SAT => FAILED("WRONG ALTERNATIVE K3"); + WHEN TUE..WED => FAILED("WRONG ALTERNATIVE K4"); + WHEN OTHERS => NULL ; + END CASE; + + CASE DAY'SUCC( DYNCON ) IS -- SAT + WHEN THU => FAILED("WRONG ALTERNATIVE L1"); + WHEN SUN => FAILED("WRONG ALTERNATIVE L2"); + WHEN SAT => NULL ; + WHEN TUE..WED => FAILED("WRONG ALTERNATIVE L4"); + WHEN OTHERS => FAILED("WRONG ALTERNATIVE L5"); + END CASE; + END ; + + + RESULT ; + + +END C54A42F ; diff --git a/gcc/testsuite/ada/acats/tests/c5/c54a42g.ada b/gcc/testsuite/ada/acats/tests/c5/c54a42g.ada new file mode 100644 index 000000000..ebe44f387 --- /dev/null +++ b/gcc/testsuite/ada/acats/tests/c5/c54a42g.ada @@ -0,0 +1,119 @@ +-- C54A42G.ADA + +-- Grant of Unlimited Rights +-- +-- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687, +-- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained +-- unlimited rights in the software and documentation contained herein. +-- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making +-- this public release, the Government intends to confer upon all +-- recipients unlimited rights equal to those held by the Government. +-- These rights include rights to use, duplicate, release or disclose the +-- released technical data and computer software in whole or in part, in +-- any manner and for any purpose whatsoever, and to have or permit others +-- to do so. +-- +-- DISCLAIMER +-- +-- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR +-- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED +-- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF 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 CASE_STATEMENT CORRECTLY HANDLES SEVERAL NON-CONTIGUOUS +-- RANGES OF INTEGERS COVERED BY A SINGLE 'OTHERS' ALTERNATIVE. + + +-- (OPTIMIZATION TEST.) + + +-- RM 03/30/81 + + +WITH REPORT; +PROCEDURE C54A42G IS + + USE REPORT ; + +BEGIN + + TEST( "C54A42G" , "TEST THAT A CASE_STATEMENT CORRECTLY HANDLES" & + " SEVERAL NON-CONTIGUOUS RANGES OF INTEGERS" & + " COVERED BY A SINGLE 'OTHERS' ALTERNATIVE" ); + + DECLARE + + NUMBER : CONSTANT := 2000 ; + LITEXPR : CONSTANT := NUMBER + 2000 ; + STATCON : CONSTANT INTEGER := 2002 ; + DYNVAR : INTEGER := IDENT_INT( 0 ); + DYNCON : CONSTANT INTEGER := IDENT_INT( 1 ); + + BEGIN + + CASE INTEGER'(-4000) IS + WHEN 100..1999 => FAILED("WRONG ALTERNATIVE F1"); + WHEN INTEGER'FIRST..0=> NULL ; + WHEN 2001 => FAILED("WRONG ALTERNATIVE F3"); + WHEN 2100..INTEGER'LAST=>FAILED("WRONG ALTERNATIVE F4"); + WHEN OTHERS => FAILED("WRONG ALTERNATIVE F5"); + END CASE; + + CASE IDENT_INT(NUMBER) IS + WHEN 100..1999 => FAILED("WRONG ALTERNATIVE G1"); + WHEN INTEGER'FIRST..0=> FAILED("WRONG ALTERNATIVE G2"); + WHEN 2001 => FAILED("WRONG ALTERNATIVE G3"); + WHEN 2100..INTEGER'LAST=>FAILED("WRONG ALTERNATIVE G4"); + WHEN OTHERS => NULL ; + END CASE; + + CASE IDENT_INT(LITEXPR) IS + WHEN 100..1999 => FAILED("WRONG ALTERNATIVE H1"); + WHEN INTEGER'FIRST..0=> FAILED("WRONG ALTERNATIVE H2"); + WHEN 2001 => FAILED("WRONG ALTERNATIVE H3"); + WHEN 2100..INTEGER'LAST=>NULL ; + WHEN OTHERS => FAILED("WRONG ALTERNATIVE H5"); + END CASE; + + CASE IDENT_INT(STATCON) IS + WHEN 100..1999 => FAILED("WRONG ALTERNATIVE I1"); + WHEN INTEGER'FIRST..0=> FAILED("WRONG ALTERNATIVE I2"); + WHEN 2001 => FAILED("WRONG ALTERNATIVE I3"); + WHEN 2100..INTEGER'LAST=>FAILED("WRONG ALTERNATIVE I4"); + WHEN OTHERS => NULL ; + END CASE; + + CASE DYNVAR IS + WHEN 100..1999 => FAILED("WRONG ALTERNATIVE J1"); + WHEN INTEGER'FIRST..0=> NULL ; + WHEN 2001 => FAILED("WRONG ALTERNATIVE J3"); + WHEN 2100..INTEGER'LAST=>FAILED("WRONG ALTERNATIVE J4"); + WHEN OTHERS => FAILED("WRONG ALTERNATIVE J5"); + END CASE; + + CASE DYNCON IS + WHEN 100..1999 => FAILED("WRONG ALTERNATIVE K1"); + WHEN INTEGER'FIRST..0=> FAILED("WRONG ALTERNATIVE K2"); + WHEN 2001 => FAILED("WRONG ALTERNATIVE K3"); + WHEN 2100..INTEGER'LAST=>FAILED("WRONG ALTERNATIVE K4"); + WHEN OTHERS => NULL ; + END CASE; + + CASE IDENT_INT( -3900 ) IS + WHEN -3000..1999 => FAILED("WRONG ALTERNATIVE X1"); + WHEN INTEGER'FIRST.. + -4000 => FAILED("WRONG ALTERNATIVE X2"); + WHEN 2001 => FAILED("WRONG ALTERNATIVE X3"); + WHEN 2100..INTEGER'LAST=>FAILED("WRONG ALTERNATIVE X4"); + WHEN OTHERS => NULL ; + END CASE; + + END ; + + + RESULT ; + + +END C54A42G ; diff --git a/gcc/testsuite/ada/acats/tests/c5/c55b03a.ada b/gcc/testsuite/ada/acats/tests/c5/c55b03a.ada new file mode 100644 index 000000000..ddcadcef8 --- /dev/null +++ b/gcc/testsuite/ada/acats/tests/c5/c55b03a.ada @@ -0,0 +1,59 @@ +-- C55B03A.ADA + +-- Grant of Unlimited Rights +-- +-- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687, +-- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained +-- unlimited rights in the software and documentation contained herein. +-- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making +-- this public release, the Government intends to confer upon all +-- recipients unlimited rights equal to those held by the Government. +-- These rights include rights to use, duplicate, release or disclose the +-- released technical data and computer software in whole or in part, in +-- any manner and for any purpose whatsoever, and to have or permit others +-- to do so. +-- +-- DISCLAIMER +-- +-- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR +-- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED +-- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF 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 LOOP_PARAMETER IS ASSIGNED VALUES IN ASCENDING ORDER +-- IF REVERSE IS ABSENT, AND DESCENDING ORDER IF REVERSE IS PRESENT. + +-- DAS 1/12/81 +-- SPS 3/2/83 + +WITH REPORT; +PROCEDURE C55B03A IS + + USE REPORT; + I1 : INTEGER; + +BEGIN + TEST( "C55B03A" , "CHECK CORRECT ORDER OF VALUE SEQUENCING" & + " FOR A LOOP_PARAMETER" ); + + I1 := 0; + FOR I IN IDENT_INT(1)..IDENT_INT(5) LOOP + I1 := I1 + 1; + IF ( I /= I1 ) THEN + FAILED ( "LOOP_PARAMETER ASCENDING INCORRECTLY" ); + END IF; + END LOOP; + + I1 := 6; + FOR I IN REVERSE IDENT_INT(1)..IDENT_INT(5) LOOP + I1 := I1 - 1; + IF ( I /= I1 ) THEN + FAILED ( "LOOP_PARAMETER DESCENDING INCORRECTLY" ); + END IF; + END LOOP; + + RESULT; + +END C55B03A; diff --git a/gcc/testsuite/ada/acats/tests/c5/c55b04a.ada b/gcc/testsuite/ada/acats/tests/c5/c55b04a.ada new file mode 100644 index 000000000..748f192e8 --- /dev/null +++ b/gcc/testsuite/ada/acats/tests/c5/c55b04a.ada @@ -0,0 +1,96 @@ +-- C55B04A.ADA + +-- Grant of Unlimited Rights +-- +-- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687, +-- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained +-- unlimited rights in the software and documentation contained herein. +-- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making +-- this public release, the Government intends to confer upon all +-- recipients unlimited rights equal to those held by the Government. +-- These rights include rights to use, duplicate, release or disclose the +-- released technical data and computer software in whole or in part, in +-- any manner and for any purpose whatsoever, and to have or permit others +-- to do so. +-- +-- DISCLAIMER +-- +-- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR +-- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED +-- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF 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 LOOP IS NOT ENTERED IF THE LOWER BOUND OF THE DISCRETE +-- RANGE IS GREATER THAN THE UPPER BOUND, WHETHER REVERSE IS PRESENT +-- OR NOT. + +-- CHECK THAT LOOP BOUNDS ARE EVALUATED ONLY ONCE, UPON ENTRY TO +-- THE LOOP. + +-- DAS 01/12/81 +-- SPS 3/2/83 +-- JBG 8/21/83 + +WITH REPORT; +PROCEDURE C55B04A IS + + USE REPORT; + + C10 : CONSTANT INTEGER := 10; + I10 : INTEGER; + +BEGIN + TEST ( "C55B04A", "CHECK OPERATION OF A FOR LOOP OVER A NULL " & + "DISCRETE RANGE" ); + + -- NOTE: EXIT STATEMENTS ARE INCLUDED TO AID IN RECOVERY FROM + -- TEST FAILURE. + + -- SUBTESTS INVOLVING STATIC BOUNDS: + + FOR I IN 10..1 LOOP + FAILED ( "LOOPING OVER NULL RANGE 10..1" ); + EXIT; + END LOOP; + + FOR I IN REVERSE INTEGER RANGE -1..-10 LOOP + FAILED ( "LOOPING OVER NULL RANGE -1..-10" ); + EXIT; + END LOOP; + + FOR I IN (C10 + 3)..(-3 * C10 + 27) LOOP -- 13..-3 + FAILED ("LOOPING OVER NULL RANGE (C10 + 3)..(-3 * C10 + 27)"); + EXIT; + END LOOP; + + + -- SUBTESTS INVOLVING DYNAMIC BOUNDS: + + I10 := IDENT_INT(10); + + FOR I IN REVERSE I10..(I10-1) LOOP -- 10..9 + FAILED ( "LOOPING OVER NULL RANGE I10..(I10-1)"); + EXIT; + END LOOP; + + + FOR I IN (C10 - I10)..(I10 - 11) LOOP -- 0..-1 + FAILED ( "LOOPING OVER NULL RANGE (C10 - I10)..(I10 - 11)" ); + EXIT; + END LOOP; + + + -- SUBTEST OF BOUNDS EVALUTION ONLY AT ENTRY: + + FOR I IN 1..I10 LOOP + I10 := I10 - 1; + END LOOP; + IF (I10 /= 0) THEN + FAILED ( "LOOP BOUNDS NOT FIXED AT LOOP ENTRY" ); + END IF; + + RESULT; + +END C55B04A; diff --git a/gcc/testsuite/ada/acats/tests/c5/c55b05a.ada b/gcc/testsuite/ada/acats/tests/c5/c55b05a.ada new file mode 100644 index 000000000..20e8ff438 --- /dev/null +++ b/gcc/testsuite/ada/acats/tests/c5/c55b05a.ada @@ -0,0 +1,170 @@ +-- C55B05A.ADA + +-- Grant of Unlimited Rights +-- +-- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687, +-- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained +-- unlimited rights in the software and documentation contained herein. +-- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making +-- this public release, the Government intends to confer upon all +-- recipients unlimited rights equal to those held by the Government. +-- These rights include rights to use, duplicate, release or disclose the +-- released technical data and computer software in whole or in part, in +-- any manner and for any purpose whatsoever, and to have or permit others +-- to do so. +-- +-- DISCLAIMER +-- +-- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR +-- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED +-- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF 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 LOOPS WITH BOUNDS INTEGER'LAST OR +-- INTEGER'FIRST DO NOT RAISE INVALID EXCEPTIONS. + +-- *** NOTE: This test has been modified since ACVC version 1.11 to -- 9X +-- *** remove incompatibilities associated with the transition -- 9X +-- *** to Ada 9X. -- 9X +-- *** -- 9X + +-- DAT 3/26/81 +-- SPS 3/2/83 +-- MRM 03/30/93 REMOVED NUMERIC_ERROR FOR 9X COMPATIBILITY + +WITH REPORT; USE REPORT; + +PROCEDURE C55B05A IS +BEGIN + TEST ("C55B05A", "LOOPS WITH INTEGER'FIRST AND 'LAST AS BOUNDS"); + + DECLARE + + COUNT : INTEGER := 0; + + PROCEDURE C IS + BEGIN + COUNT := COUNT + 1; + END C; + + BEGIN + FOR I IN INTEGER'LAST .. INTEGER'FIRST LOOP + FAILED ("WRONG NULL RANGE LOOP EXECUTION"); + EXIT; + END LOOP; + FOR I IN INTEGER'FIRST .. INTEGER'FIRST LOOP + C; + END LOOP; + FOR I IN INTEGER'FIRST .. INTEGER'FIRST + 2 LOOP + C; C; + END LOOP; + FOR I IN INTEGER'FIRST + 1 .. INTEGER'FIRST LOOP + FAILED ("NULL RANGE ERROR 2"); + EXIT; + END LOOP; + FOR I IN INTEGER'FIRST .. INTEGER'LAST LOOP + C; + EXIT; + END LOOP; + FOR I IN INTEGER LOOP + C; + EXIT; + END LOOP; + FOR I IN INTEGER'LAST - 2 .. INTEGER'LAST LOOP + C; C; C; + END LOOP; + FOR I IN INTEGER'LAST - 2 .. INTEGER'LAST - 1 LOOP + C; + END LOOP; + FOR I IN 0 .. INTEGER'FIRST LOOP + FAILED ("NULL LOOP ERROR 3"); + EXIT; + END LOOP; + FOR I IN -1 .. INTEGER'FIRST LOOP + FAILED ("NULL LOOP ERROR 4"); + EXIT; + END LOOP; + FOR I IN -3 .. IDENT_INT(0) LOOP + FOR J IN INTEGER'FIRST .. INTEGER'FIRST - I LOOP + C; C; C; C; + END LOOP; + FOR J IN INTEGER'FIRST - I .. INTEGER'FIRST + 3 - I LOOP + C; C; C; C; + END LOOP; + FOR J IN INTEGER'LAST - 3 .. INTEGER'LAST + I LOOP + C; C; C; C; + END LOOP; + FOR J IN INTEGER'LAST + I .. INTEGER'LAST LOOP + C; C; C; C; + END LOOP; + END LOOP; + + FOR I IN REVERSE INTEGER'LAST .. INTEGER'FIRST LOOP + FAILED ("REVERSE WRONG NULL RANGE LOOP EXECUTION"); + EXIT; + END LOOP; + FOR I IN REVERSE INTEGER'FIRST .. INTEGER'FIRST LOOP + C; + END LOOP; + FOR I IN REVERSE INTEGER'FIRST .. INTEGER'FIRST + 2 LOOP + C; C; + END LOOP; + FOR I IN REVERSE INTEGER'FIRST + 1 .. INTEGER'FIRST LOOP + FAILED ("NULL RANGE ERROR 8"); + EXIT; + END LOOP; + FOR I IN REVERSE INTEGER'FIRST .. INTEGER'LAST LOOP + C; + EXIT; + END LOOP; + FOR I IN REVERSE INTEGER LOOP + C; + EXIT; + END LOOP; + FOR I IN REVERSE INTEGER'LAST - 2 .. INTEGER'LAST LOOP + C; C; C; + END LOOP; + FOR I IN REVERSE INTEGER'LAST - 2 .. INTEGER'LAST - 1 LOOP + C; + END LOOP; + FOR I IN REVERSE 0 .. INTEGER'FIRST LOOP + FAILED ("NULL LOOP ERROR 9"); + EXIT; + END LOOP; + FOR I IN REVERSE -1 .. INTEGER'FIRST LOOP + FAILED ("NULL LOOP ERROR 7"); + EXIT; + END LOOP; + FOR I IN REVERSE -3 .. IDENT_INT(0) LOOP + FOR J IN REVERSE INTEGER'FIRST .. INTEGER'FIRST - I LOOP + C; C; C; C; + END LOOP; + FOR J IN REVERSE INTEGER'FIRST - I + .. INTEGER'FIRST + 3 - I + LOOP + C; C; C; C; + END LOOP; + FOR J IN REVERSE INTEGER'LAST - 3 .. INTEGER'LAST + I + LOOP + C; C; C; C; + END LOOP; + FOR J IN REVERSE INTEGER'LAST + I .. INTEGER'LAST LOOP + C; C; C; C; + END LOOP; + END LOOP; + + IF COUNT /= 408 THEN + FAILED ("WRONG LOOP EXECUTION COUNT"); + END IF; + + EXCEPTION + WHEN CONSTRAINT_ERROR => + FAILED ("CONSTRAINT_ERROR RAISED INCORRECTLY"); + WHEN OTHERS => + FAILED ("UNKNOWN EXCEPTION RAISED INCORRECTLY"); + END; + + RESULT; +END C55B05A; diff --git a/gcc/testsuite/ada/acats/tests/c5/c55b06a.ada b/gcc/testsuite/ada/acats/tests/c5/c55b06a.ada new file mode 100644 index 000000000..524de24f7 --- /dev/null +++ b/gcc/testsuite/ada/acats/tests/c5/c55b06a.ada @@ -0,0 +1,313 @@ +-- C55B06A.ADA + +-- Grant of Unlimited Rights +-- +-- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687, +-- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained +-- unlimited rights in the software and documentation contained herein. +-- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making +-- this public release, the Government intends to confer upon all +-- recipients unlimited rights equal to those held by the Government. +-- These rights include rights to use, duplicate, release or disclose the +-- released technical data and computer software in whole or in part, in +-- any manner and for any purpose whatsoever, and to have or permit others +-- to do so. +-- +-- DISCLAIMER +-- +-- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR +-- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED +-- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF 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 LOOPS MAY BE SPECIFIED FOR BOOLEAN, INTEGER, +-- CHARACTER, ENUMERATION, AND DERIVED TYPES, INCLUDING +-- TYPES DERIVED FROM DERIVED TYPES. DERIVED BOOLEAN IS NOT +-- TESTED IN THIS TEST. + +-- DAT 3/26/81 +-- JBG 9/29/82 +-- SPS 3/11/83 +-- JBG 10/5/83 +-- PWN 01/31/95 REMOVED INCONSISTENCIES WITH ADA 9X. + +WITH REPORT; USE REPORT; + +PROCEDURE C55B06A IS + + TYPE ENUM IS ('A', 'B', 'D', 'C', Z, X, D, A, C); + + TYPE D1 IS NEW CHARACTER RANGE 'A' .. 'Z'; + TYPE D2 IS NEW INTEGER; + TYPE D3 IS NEW ENUM; + TYPE D4 IS NEW D1; + TYPE D5 IS NEW D2; + TYPE D6 IS NEW D3; + + ONE : INTEGER := IDENT_INT(1); + COUNT : INTEGER := 0; + OLDCOUNT : INTEGER := 0; + + PROCEDURE Q IS + BEGIN + COUNT := COUNT + ONE; + END Q; + +BEGIN + TEST ("C55B06A", "TEST LOOPS FOR ALL DISCRETE TYPES"); + + FOR I IN BOOLEAN LOOP + Q; + END LOOP; + IF OLDCOUNT + IDENT_INT(2) /= COUNT THEN + FAILED ("LOOP 1"); + END IF; + OLDCOUNT := COUNT; + + FOR I IN FALSE .. TRUE LOOP + Q; + END LOOP; + IF OLDCOUNT + IDENT_INT(2) /= COUNT THEN + FAILED ("LOOP 2"); + END IF; + OLDCOUNT := COUNT; + + FOR I IN BOOLEAN RANGE FALSE .. TRUE LOOP + Q; + END LOOP; + IF OLDCOUNT + IDENT_INT(2) /= COUNT THEN + FAILED ("LOOP 3"); + END IF; + OLDCOUNT := COUNT; + + FOR I IN INTEGER LOOP + Q; + EXIT WHEN I = INTEGER'FIRST + 2; + END LOOP; + IF OLDCOUNT + IDENT_INT(3) /= COUNT THEN + FAILED ("LOOP 4"); + END IF; + OLDCOUNT := COUNT; + + FOR I IN 3 .. IDENT_INT (5) LOOP + Q; + END LOOP; + IF OLDCOUNT + IDENT_INT(3) /= COUNT THEN + FAILED ("LOOP 5"); + END IF; + OLDCOUNT := COUNT; + + FOR I IN INTEGER RANGE -2 .. -1 LOOP + Q; + END LOOP; + IF OLDCOUNT + IDENT_INT(2) /= COUNT THEN + FAILED ("LOOP 6"); + END IF; + OLDCOUNT := COUNT; + + FOR I IN INTEGER RANGE INTEGER'FIRST .. INTEGER'FIRST + 1 LOOP + Q; + END LOOP; + IF OLDCOUNT + IDENT_INT(2) /= COUNT THEN + FAILED ("LOOP 7"); + END IF; + OLDCOUNT := COUNT; + + FOR I IN 'A' .. CHARACTER'('Z') LOOP + Q; + END LOOP; + IF OLDCOUNT + IDENT_INT(26) /= COUNT THEN + FAILED ("LOOP 9"); + END IF; + OLDCOUNT := COUNT; + + FOR I IN CHARACTER RANGE 'A' .. 'D' LOOP + Q; + END LOOP; + IF OLDCOUNT + IDENT_INT(4) /= COUNT THEN + FAILED ("LOOP 10"); + END IF; + OLDCOUNT := COUNT; + + FOR I IN ENUM LOOP + Q; + END LOOP; + IF OLDCOUNT + IDENT_INT(9) /= COUNT THEN + FAILED ("LOOP 11"); + END IF; + OLDCOUNT := COUNT; + + FOR I IN ENUM RANGE D .. C LOOP + Q; + END LOOP; + IF OLDCOUNT + IDENT_INT(3) /= COUNT THEN + FAILED ("LOOP 12"); + END IF; + OLDCOUNT := COUNT; + + FOR I IN 'A' .. ENUM'(Z) LOOP + Q; + END LOOP; + IF OLDCOUNT + IDENT_INT(5) /= COUNT THEN + FAILED ("LOOP 13"); + END IF; + OLDCOUNT := COUNT; + + FOR I IN D1 LOOP + Q; + END LOOP; + IF OLDCOUNT + IDENT_INT(26) /= COUNT THEN + FAILED ("LOOP 14"); + END IF; + OLDCOUNT := COUNT; + + FOR I IN D1 RANGE 'A' .. 'Z' LOOP + Q; + END LOOP; + IF OLDCOUNT + IDENT_INT(26) /= COUNT THEN + FAILED ("LOOP 15"); + END IF; + OLDCOUNT := COUNT; + + FOR I IN D1'('A') .. 'D' LOOP + Q; + END LOOP; + IF OLDCOUNT + IDENT_INT(4) /= COUNT THEN + FAILED ("LOOP 16"); + END IF; + OLDCOUNT := COUNT; + + FOR I IN D2 LOOP + Q; + IF I > D2'FIRST + 3 THEN + EXIT; + END IF; + END LOOP; + IF OLDCOUNT + IDENT_INT(5) /= COUNT THEN + FAILED ("LOOP 17"); + END IF; + OLDCOUNT := COUNT; + + FOR I IN D2 RANGE -100 .. -99 LOOP + Q; + END LOOP; + IF OLDCOUNT + IDENT_INT(2) /= COUNT THEN + FAILED ("LOOP 18"); + END IF; + OLDCOUNT := COUNT; + + FOR I IN D2'(1) .. 2 LOOP + Q; + END LOOP; + IF OLDCOUNT + IDENT_INT(2) /= COUNT THEN + FAILED ("LOOP 19"); + END IF; + OLDCOUNT := COUNT; + + FOR I IN D3 LOOP + IF I IN 'A' .. 'C' THEN + Q; -- 4 + ELSE + Q; Q; -- 10 + END IF; + END LOOP; + IF OLDCOUNT + IDENT_INT(14) /= COUNT THEN + FAILED ("LOOP 20"); + END IF; + OLDCOUNT := COUNT; + + FOR I IN D3 RANGE 'A' .. Z LOOP + Q; + END LOOP; + IF OLDCOUNT + IDENT_INT(5) /= COUNT THEN + FAILED ("LOOP 21"); + END IF; + OLDCOUNT := COUNT; + + FOR I IN 'A' .. D3'(Z) LOOP + Q; + END LOOP; + IF OLDCOUNT + IDENT_INT(5) /= COUNT THEN + FAILED ("LOOP 22"); + END IF; + OLDCOUNT := COUNT; + + FOR I IN D4 LOOP + Q; + END LOOP; + IF OLDCOUNT + IDENT_INT(26) /= COUNT THEN + FAILED ("LOOP 23"); + END IF; + OLDCOUNT := COUNT; + + FOR I IN D4'('A') .. 'Z' LOOP + Q; + END LOOP; + IF OLDCOUNT + IDENT_INT(26) /= COUNT THEN + FAILED ("LOOP 24"); + END IF; + OLDCOUNT := COUNT; + + FOR I IN D4 RANGE 'B' .. 'D' LOOP + Q; + END LOOP; + IF OLDCOUNT + IDENT_INT(3) /= COUNT THEN + FAILED ("LOOP 25"); + END IF; + OLDCOUNT := COUNT; + + FOR J IN D5 LOOP + Q; -- 4 + EXIT WHEN J = D5(INTEGER'FIRST) + 3; + Q; -- 3 + END LOOP; + IF OLDCOUNT + IDENT_INT(7) /= COUNT THEN + FAILED ("LOOP 26"); + END IF; + OLDCOUNT := COUNT; + + FOR J IN D5 RANGE -2 .. -1 LOOP + Q; + END LOOP; + IF OLDCOUNT + IDENT_INT(2) /= COUNT THEN + FAILED ("LOOP 27"); + END IF; + OLDCOUNT := COUNT; + + FOR J IN D5'(-10) .. D5'(-6) LOOP + Q; + END LOOP; + IF OLDCOUNT + IDENT_INT(5) /= COUNT THEN + FAILED ("LOOP 28"); + END IF; + OLDCOUNT := COUNT; + + FOR J IN D6 LOOP + Q; + END LOOP; + IF OLDCOUNT + IDENT_INT(9) /= COUNT THEN + FAILED ("LOOP 29"); + END IF; + OLDCOUNT := COUNT; + + FOR J IN D6 RANGE Z .. A LOOP + Q; + END LOOP; + IF OLDCOUNT + IDENT_INT(4) /= COUNT THEN + FAILED ("LOOP 30"); + END IF; + OLDCOUNT := COUNT; + + FOR J IN D6'('D') .. D LOOP + Q; + END LOOP; + IF OLDCOUNT + IDENT_INT(5) /= COUNT THEN + FAILED ("LOOP 31"); + END IF; + OLDCOUNT := COUNT; + + + RESULT; +END C55B06A; diff --git a/gcc/testsuite/ada/acats/tests/c5/c55b06b.ada b/gcc/testsuite/ada/acats/tests/c5/c55b06b.ada new file mode 100644 index 000000000..4bff008dd --- /dev/null +++ b/gcc/testsuite/ada/acats/tests/c5/c55b06b.ada @@ -0,0 +1,188 @@ +-- C55B06B.ADA + +-- Grant of Unlimited Rights +-- +-- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687, +-- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained +-- unlimited rights in the software and documentation contained herein. +-- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making +-- this public release, the Government intends to confer upon all +-- recipients unlimited rights equal to those held by the Government. +-- These rights include rights to use, duplicate, release or disclose the +-- released technical data and computer software in whole or in part, in +-- any manner and for any purpose whatsoever, and to have or permit others +-- to do so. +-- +-- DISCLAIMER +-- +-- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR +-- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED +-- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF 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 LOOPS MAY BE SPECIFIED FOR DERIVED BOOLEAN AND +-- DERIVED DERIVED BOOLEAN. + +-- DAT 3/26/81 +-- SPS 3/2/83 + +WITH REPORT; USE REPORT; + +PROCEDURE C55B06B IS + + TYPE E IS (FALSE, TRUE); + TYPE B1 IS NEW BOOLEAN; + TYPE B2 IS NEW B1; + TYPE B3 IS NEW E; + + ONE : INTEGER := IDENT_INT (1); + COUNT : INTEGER := 0; + OLD_COUNT : INTEGER := 0; + + PROCEDURE Q IS + BEGIN + COUNT := COUNT + 1; + END Q; + +BEGIN + TEST ("C55B06B", "LOOPS OVER DERIVED BOOLEAN"); + + FOR I IN BOOLEAN LOOP + Q; + END LOOP; + IF OLD_COUNT + IDENT_INT (2) /= COUNT THEN + FAILED ("LOOP 1"); + ELSE + OLD_COUNT := COUNT; + END IF; + + FOR I IN BOOLEAN RANGE FALSE .. TRUE LOOP + Q; + END LOOP; + IF OLD_COUNT + IDENT_INT (2) /= COUNT THEN + FAILED ("LOOP 2"); + ELSE + OLD_COUNT := COUNT; + END IF; + + FOR I IN BOOLEAN'(FALSE) .. TRUE LOOP + Q; + END LOOP; + IF OLD_COUNT + IDENT_INT (2) /= COUNT THEN + FAILED ("LOOP 3"); + ELSE + OLD_COUNT := COUNT; + END IF; + + FOR I IN E LOOP + Q; + END LOOP; + IF OLD_COUNT + IDENT_INT (2) /= COUNT THEN + FAILED ("LOOP 4"); + ELSE + OLD_COUNT := COUNT; + END IF; + + FOR I IN E RANGE FALSE .. TRUE LOOP + Q; + END LOOP; + IF OLD_COUNT + IDENT_INT (2) /= COUNT THEN + FAILED ("LOOP 5"); + ELSE + OLD_COUNT := COUNT; + END IF; + + FOR I IN FALSE .. E'(TRUE) LOOP + Q; + END LOOP; + IF OLD_COUNT + IDENT_INT (2) /= COUNT THEN + FAILED ("LOOP 6"); + ELSE + OLD_COUNT := COUNT; + END IF; + + FOR I IN B1 LOOP + Q; + END LOOP; + IF OLD_COUNT + IDENT_INT (2) /= COUNT THEN + FAILED ("LOOP 7"); + ELSE + OLD_COUNT := COUNT; + END IF; + + FOR I IN B1 RANGE FALSE .. TRUE LOOP + Q; + END LOOP; + IF OLD_COUNT + IDENT_INT (2) /= COUNT THEN + FAILED ("LOOP 8"); + ELSE + OLD_COUNT := COUNT; + END IF; + + FOR I IN FALSE .. B1'(TRUE) LOOP + Q; + END LOOP; + IF OLD_COUNT + IDENT_INT (2) /= COUNT THEN + FAILED ("LOOP 9"); + ELSE + OLD_COUNT := COUNT; + END IF; + + FOR I IN B2 LOOP + Q; + END LOOP; + IF OLD_COUNT + IDENT_INT (2) /= COUNT THEN + FAILED ("LOOP 10"); + ELSE + OLD_COUNT := COUNT; + END IF; + + FOR I IN B2 RANGE FALSE .. TRUE LOOP + Q; + END LOOP; + IF OLD_COUNT + IDENT_INT (2) /= COUNT THEN + FAILED ("LOOP 11"); + ELSE + OLD_COUNT := COUNT; + END IF; + + FOR I IN B2'(FALSE) .. TRUE LOOP + Q; + END LOOP; + IF OLD_COUNT + IDENT_INT (2) /= COUNT THEN + FAILED ("LOOP 12"); + ELSE + OLD_COUNT := COUNT; + END IF; + + FOR I IN B3 LOOP + Q; + END LOOP; + IF OLD_COUNT + IDENT_INT (2) /= COUNT THEN + FAILED ("LOOP 13"); + ELSE + OLD_COUNT := COUNT; + END IF; + + FOR I IN B3 RANGE FALSE .. TRUE LOOP + Q; + END LOOP; + IF OLD_COUNT + IDENT_INT (2) /= COUNT THEN + FAILED ("LOOP 14"); + ELSE + OLD_COUNT := COUNT; + END IF; + + FOR I IN FALSE .. B3'(TRUE) LOOP + Q; + END LOOP; + IF OLD_COUNT + IDENT_INT (2) /= COUNT THEN + FAILED ("LOOP 15"); + ELSE + OLD_COUNT := COUNT; + END IF; + + RESULT; + END C55B06B; diff --git a/gcc/testsuite/ada/acats/tests/c5/c55b07a.dep b/gcc/testsuite/ada/acats/tests/c5/c55b07a.dep new file mode 100644 index 000000000..22c2ce491 --- /dev/null +++ b/gcc/testsuite/ada/acats/tests/c5/c55b07a.dep @@ -0,0 +1,126 @@ +-- C55B07A.DEP + +-- Grant of Unlimited Rights +-- +-- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687, +-- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained +-- unlimited rights in the software and documentation contained herein. +-- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making +-- this public release, the Government intends to confer upon all +-- recipients unlimited rights equal to those held by the Government. +-- These rights include rights to use, duplicate, release or disclose the +-- released technical data and computer software in whole or in part, in +-- any manner and for any purpose whatsoever, and to have or permit others +-- to do so. +-- +-- DISCLAIMER +-- +-- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR +-- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED +-- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF 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 LOOPS OVER RANGES OF TYPE LONG_INTEGER +-- CAN BE WRITTEN. + +-- APPLICABILITY CRITERIA: +-- THIS TEST IS APPLICABLE TO IMPLEMENTATIONS WHICH SUPPORT +-- THE TYPE LONG_INTEGER. +-- +-- IF THE TYPE LONG_INTEGER IS NOT SUPPORTED, THEN THE +-- DECLARATION OF CHECK MUST BE REJECTED. + +-- HISTORY: +-- RM 07/06/82 CREATED ORIGINAL TEST. +-- BCB 01/04/88 MODIFIED HEADER. + + +WITH REPORT; USE REPORT; + +PROCEDURE C55B07A IS + + CHECK : LONG_INTEGER; -- N/A => ERROR. + + TYPE NEW_LONG_INTEGER IS NEW LONG_INTEGER ; + + THE_COUNT : INTEGER := 777 ; -- JUST A DUMMY... + + LI_VAR : LONG_INTEGER := 1 ; + LI_CON : CONSTANT LONG_INTEGER := 1 ; + + NLI_VAR : NEW_LONG_INTEGER := 1 ; + NLI_CON : CONSTANT NEW_LONG_INTEGER := 1 ; + + SUBTYPE LI_SEGMENT IS LONG_INTEGER RANGE + LONG_INTEGER'LAST..LONG_INTEGER'LAST ; + + SUBTYPE NLI_SEGMENT IS NEW_LONG_INTEGER RANGE + NEW_LONG_INTEGER'FIRST.. + NEW_LONG_INTEGER'FIRST ; + + COUNT : INTEGER := 0; + + PROCEDURE BUMP ( DUMMY : INTEGER ) IS + BEGIN + COUNT := COUNT + 1; + END BUMP; + +BEGIN + + TEST ( "C55B07A" , "LOOPS OVER RANGES OF TYPE LONG_INTEGER " ); + + FOR I IN 1..LI_CON LOOP + BUMP(THE_COUNT) ; + END LOOP; + + FOR I IN NLI_VAR..1 LOOP + BUMP(THE_COUNT) ; + END LOOP; + + FOR I IN 1..LONG_INTEGER(1) LOOP + BUMP(THE_COUNT) ; + END LOOP; + + FOR I IN 1..NEW_LONG_INTEGER(1) LOOP + BUMP(THE_COUNT) ; + END LOOP; + + FOR I IN LI_SEGMENT LOOP + BUMP(THE_COUNT) ; + END LOOP; + + FOR I IN REVERSE NLI_SEGMENT LOOP + BUMP(THE_COUNT) ; + END LOOP; + + FOR I IN LONG_INTEGER RANGE 1..1 LOOP + BUMP(THE_COUNT) ; + END LOOP; + + FOR I IN NEW_LONG_INTEGER RANGE 1..1 LOOP + BUMP(THE_COUNT) ; + END LOOP; + + FOR I IN LONG_INTEGER LOOP + BUMP(THE_COUNT) ; + EXIT WHEN I = LONG_INTEGER'FIRST + 1; + END LOOP; + + FOR I IN NEW_LONG_INTEGER LOOP + BUMP(THE_COUNT) ; + EXIT WHEN I = NEW_LONG_INTEGER'FIRST + 1; + END LOOP; + + + IF COUNT /= 12 THEN + FAILED ("WRONG LOOP COUNT"); + END IF; + + + RESULT; + + +END C55B07A ; diff --git a/gcc/testsuite/ada/acats/tests/c5/c55b07b.dep b/gcc/testsuite/ada/acats/tests/c5/c55b07b.dep new file mode 100644 index 000000000..17c0c6b04 --- /dev/null +++ b/gcc/testsuite/ada/acats/tests/c5/c55b07b.dep @@ -0,0 +1,126 @@ +-- C55B07B.DEP + +-- Grant of Unlimited Rights +-- +-- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687, +-- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained +-- unlimited rights in the software and documentation contained herein. +-- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making +-- this public release, the Government intends to confer upon all +-- recipients unlimited rights equal to those held by the Government. +-- These rights include rights to use, duplicate, release or disclose the +-- released technical data and computer software in whole or in part, in +-- any manner and for any purpose whatsoever, and to have or permit others +-- to do so. +-- +-- DISCLAIMER +-- +-- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR +-- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED +-- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF 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 LOOPS OVER RANGES OF TYPE SHORT_INTEGER +-- CAN BE WRITTEN. + +-- APPLICABILITY CRITERIA: +-- THIS TEST IS APPLICABLE TO IMPLEMENTATIONS WHICH SUPPORT +-- THE TYPE SHORT_INTEGER. +-- +-- IF THE TYPE SHORT_INTEGER IS NOT SUPPORTED, THEN THE +-- DECLARATION OF CHECK MUST BE REJECTED. + +-- HISTORY: +-- RM 07/08/82 CREATED ORIGINAL TEST. +-- BCB 01/04/88 MODIFIED HEADER. + + +WITH REPORT; USE REPORT; + +PROCEDURE C55B07B IS + + CHECK : SHORT_INTEGER; -- N/A => ERROR. + + TYPE NEW_SHORT_INTEGER IS NEW SHORT_INTEGER ; + + THE_COUNT : INTEGER := 777 ; -- JUST A DUMMY... + + SI_VAR : SHORT_INTEGER := 1 ; + SI_CON : CONSTANT SHORT_INTEGER := 1 ; + + NSI_VAR : NEW_SHORT_INTEGER := 1 ; + NSI_CON : CONSTANT NEW_SHORT_INTEGER := 1 ; + + SUBTYPE SI_SEGMENT IS SHORT_INTEGER RANGE + SHORT_INTEGER'LAST..SHORT_INTEGER'LAST ; + + SUBTYPE NSI_SEGMENT IS NEW_SHORT_INTEGER RANGE + NEW_SHORT_INTEGER'FIRST.. + NEW_SHORT_INTEGER'FIRST ; + + COUNT : INTEGER := 0; + + PROCEDURE BUMP ( DUMMY : INTEGER ) IS + BEGIN + COUNT := COUNT + 1; + END BUMP; + +BEGIN + + TEST ( "C55B07B" , "LOOPS OVER RANGES OF TYPE SHORT_INTEGER " ); + + FOR I IN 1..SI_CON LOOP + BUMP(THE_COUNT) ; + END LOOP; + + FOR I IN NSI_VAR..1 LOOP + BUMP(THE_COUNT) ; + END LOOP; + + FOR I IN 1..SHORT_INTEGER(1) LOOP + BUMP(THE_COUNT) ; + END LOOP; + + FOR I IN 1..NEW_SHORT_INTEGER(1) LOOP + BUMP(THE_COUNT) ; + END LOOP; + + FOR I IN SI_SEGMENT LOOP + BUMP(THE_COUNT) ; + END LOOP; + + FOR I IN REVERSE NSI_SEGMENT LOOP + BUMP(THE_COUNT) ; + END LOOP; + + FOR I IN SHORT_INTEGER RANGE 1..1 LOOP + BUMP(THE_COUNT) ; + END LOOP; + + FOR I IN NEW_SHORT_INTEGER RANGE 1..1 LOOP + BUMP(THE_COUNT) ; + END LOOP; + + FOR I IN SHORT_INTEGER LOOP + BUMP(THE_COUNT) ; + EXIT WHEN I = SHORT_INTEGER'FIRST + 1; + END LOOP; + + FOR I IN NEW_SHORT_INTEGER LOOP + BUMP(THE_COUNT) ; + EXIT WHEN I = NEW_SHORT_INTEGER'FIRST + 1; + END LOOP; + + + IF COUNT /= 12 THEN + FAILED ("WRONG LOOP COUNT"); + END IF; + + + RESULT; + + +END C55B07B ; diff --git a/gcc/testsuite/ada/acats/tests/c5/c55b10a.ada b/gcc/testsuite/ada/acats/tests/c5/c55b10a.ada new file mode 100644 index 000000000..46773d46d --- /dev/null +++ b/gcc/testsuite/ada/acats/tests/c5/c55b10a.ada @@ -0,0 +1,80 @@ +-- C55B10A.ADA + +-- Grant of Unlimited Rights +-- +-- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687, +-- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained +-- unlimited rights in the software and documentation contained herein. +-- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making +-- this public release, the Government intends to confer upon all +-- recipients unlimited rights equal to those held by the Government. +-- These rights include rights to use, duplicate, release or disclose the +-- released technical data and computer software in whole or in part, in +-- any manner and for any purpose whatsoever, and to have or permit others +-- to do so. +-- +-- DISCLAIMER +-- +-- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR +-- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED +-- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE +-- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE +-- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A +-- PARTICULAR PURPOSE OF SAID MATERIAL. +--* +-- OBJECTIVE: +-- CHECK THAT, IN 'FOR I IN L .. R LOOP', IF EITHER L OR R IS AN +-- OVERLOADED ENUMERATION LITERAL, THE OVERLOADING IS CORRECTLY +-- RESOLVED AND THE LOOP PARAMETER HAS THE APPROPRIATE TYPE. + +-- HISTORY: +-- DHH 08/15/88 CREATED ORIGINAL TEST. + +WITH REPORT; USE REPORT; +PROCEDURE C55B10A IS + + TYPE ENUM IS (ALPH, BET, NEITHER); + + GLOBAL : ENUM := NEITHER; + + TYPE ALPHA IS (A, B, C, D, E); + TYPE BETA IS (G, F, E, D, C); + + PROCEDURE VAR(DEC : ALPHA) IS + BEGIN + IF EQUAL(3, 3) THEN + GLOBAL := ALPH; + END IF; + END; + + PROCEDURE VAR(DEC : BETA) IS + BEGIN + IF EQUAL(3, 3) THEN + GLOBAL := BET; + END IF; + END; + +BEGIN + TEST("C55B10A", "CHECK THAT, IN 'FOR I IN L .. R LOOP', IF " & + "EITHER L OR R IS AN OVERLOADED ENUMERATION " & + "LITERAL, THE OVERLOADING IS CORRECTLY RESOLVED " & + "AND THE LOOP PARAMETER HAS THE APPROPRIATE TYPE"); + + FOR I IN A .. E LOOP + VAR(I); + + IF GLOBAL /= ALPH THEN + FAILED("WRONG TYPE FOR ALPHA"); + END IF; + END LOOP; + + FOR I IN G .. E LOOP + VAR(I); + + IF GLOBAL /= BET THEN + FAILED("WRONG TYPE FOR BETA"); + END IF; + END LOOP; + + RESULT; +END C55B10A; diff --git a/gcc/testsuite/ada/acats/tests/c5/c55b11a.ada b/gcc/testsuite/ada/acats/tests/c5/c55b11a.ada new file mode 100644 index 000000000..4dae09714 --- /dev/null +++ b/gcc/testsuite/ada/acats/tests/c5/c55b11a.ada @@ -0,0 +1,104 @@ +-- C55B11A.ADA + +-- Grant of Unlimited Rights +-- +-- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687, +-- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained +-- unlimited rights in the software and documentation contained herein. +-- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making +-- this public release, the Government intends to confer upon all +-- recipients unlimited rights equal to those held by the Government. +-- These rights include rights to use, duplicate, release or disclose the +-- released technical data and computer software in whole or in part, in +-- any manner and for any purpose whatsoever, and to have or permit others +-- to do so. +-- +-- DISCLAIMER +-- +-- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR +-- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED +-- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE +-- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE +-- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A +-- PARTICULAR PURPOSE OF SAID MATERIAL. +--* +-- OBJECTIVE: +-- CHECK THAT, IN 'FOR IN ST RANGE L .. R LOOP', THE PARAMETER IS OF +-- THE TYPE ST'BASE; THAT IS THAT IT CAN BE ASSIGNED TO OTHER +-- VARIABLES DECLARED WITH SOME OTHER SUBTYPES OF ST. + +-- HISTORY: +-- DHH 08/15/88 CREATED ORIGINAL TEST. + +WITH REPORT; USE REPORT; +PROCEDURE C55B11A IS + + TYPE ENUM IS (A, B, C, D, E, F, G, H); + + SUBTYPE ONE IS ENUM RANGE A .. H; + SUBTYPE TWO IS ENUM RANGE B .. H; + SUBTYPE THREE IS ENUM RANGE C .. H; + SUBTYPE FOUR IS ENUM RANGE D .. H; + + GLOBAL : INTEGER := 0; + + VAR_1 : ONE; + VAR_2 : TWO; + VAR_3 : THREE; + VAR_4 : FOUR; + + PROCEDURE CHECK_VAR(T : ENUM) IS + BEGIN + GLOBAL := GLOBAL + 1; + CASE T IS + WHEN D => + IF GLOBAL /= IDENT_INT(1) THEN + FAILED("VAR_1 WRONG VALUE"); + END IF; + + WHEN E => + IF GLOBAL /= IDENT_INT(2) THEN + FAILED("VAR_2 WRONG VALUE"); + END IF; + + WHEN F => + IF GLOBAL /= IDENT_INT(3) THEN + FAILED("VAR_3 WRONG VALUE"); + END IF; + + WHEN G => + IF GLOBAL /= IDENT_INT(4) THEN + FAILED("VAR_4 WRONG VALUE"); + END IF; + + WHEN OTHERS => + + FAILED("WRONG VALUE TO PROCEDURE"); + END CASE; + END CHECK_VAR; + +BEGIN + TEST("C55B11A", "CHECK THAT, IN 'FOR IN ST RANGE L .. R LOOP', " & + "THE PARAMETER IS OF THE TYPE ST'BASE; THAT IS " & + "THAT IT CAN BE ASSIGNED TO OTHER VARIABLES " & + "DECLARED WITH SOME OTHER SUBTYPES OF ST"); + + FOR I IN ONE RANGE D .. G LOOP + CASE I IS + WHEN D => + VAR_1 := I; + CHECK_VAR(VAR_1); + WHEN E => + VAR_2 := I; + CHECK_VAR(VAR_2); + WHEN F => + VAR_3 := I; + CHECK_VAR(VAR_3); + WHEN G => + VAR_4 := I; + CHECK_VAR(VAR_4); + END CASE; + END LOOP; + + RESULT; +END C55B11A; diff --git a/gcc/testsuite/ada/acats/tests/c5/c55b11b.ada b/gcc/testsuite/ada/acats/tests/c5/c55b11b.ada new file mode 100644 index 000000000..3d1b48846 --- /dev/null +++ b/gcc/testsuite/ada/acats/tests/c5/c55b11b.ada @@ -0,0 +1,86 @@ +-- C55B11B.ADA + +-- Grant of Unlimited Rights +-- +-- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687, +-- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained +-- unlimited rights in the software and documentation contained herein. +-- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making +-- this public release, the Government intends to confer upon all +-- recipients unlimited rights equal to those held by the Government. +-- These rights include rights to use, duplicate, release or disclose the +-- released technical data and computer software in whole or in part, in +-- any manner and for any purpose whatsoever, and to have or permit others +-- to do so. +-- +-- DISCLAIMER +-- +-- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR +-- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED +-- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF 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 FORM 'FOR I IN ST RANGE L .. R LOOP' IS ACCEPTED +-- EVEN IF BOTH L AND R ARE OVERLOADED ENUMERATION LITERALS (SO +-- THAT L .. R WOULD BE ILLEGAL WITHOUT ST RANGE). + +-- HISTORY: +-- DHH 09/07/88 CREATED ORIGINAL TEST. + +WITH REPORT; USE REPORT; +PROCEDURE C55B11B IS + TYPE ST IS (A, B, C, D, E, F, G, H); + TYPE SI IS (A, B, C, D, F, E, G, H); + + GLOBAL : INTEGER := 0; + + PROCEDURE CHECK_VAR(T : ST) IS + BEGIN + GLOBAL := GLOBAL + 1; + CASE T IS + WHEN D => + IF GLOBAL /= IDENT_INT(1) THEN + FAILED("1 WRONG VALUE"); + END IF; + + WHEN E => + IF GLOBAL /= IDENT_INT(2) THEN + FAILED("2 WRONG VALUE"); + END IF; + + WHEN F => + IF GLOBAL /= IDENT_INT(3) THEN + FAILED("3 WRONG VALUE"); + END IF; + + WHEN G => + IF GLOBAL /= IDENT_INT(4) THEN + FAILED("4 WRONG VALUE"); + END IF; + + WHEN OTHERS => + FAILED("WRONG VALUE TO PROCEDURE"); + + END CASE; + END CHECK_VAR; + + PROCEDURE CHECK_VAR(T : SI) IS + BEGIN + FAILED("WRONG PROCEDURE CALLED"); + END CHECK_VAR; + +BEGIN + TEST ("C55B11B", "CHECK THAT THE 'FORM FOR I IN ST RANGE L .. R " & + "LOOP' IS ACCEPTED EVEN IF BOTH L AND R ARE " & + "OVERLOADED ENUMERATION LITERALS (SO THAT L .. " & + "R WOULD BE ILLEGAL WITHOUT ST RANGE)"); + + FOR I IN ST RANGE D .. G LOOP + CHECK_VAR(I); + END LOOP; + + RESULT; +END C55B11B; diff --git a/gcc/testsuite/ada/acats/tests/c5/c55b15a.ada b/gcc/testsuite/ada/acats/tests/c5/c55b15a.ada new file mode 100644 index 000000000..a04941962 --- /dev/null +++ b/gcc/testsuite/ada/acats/tests/c5/c55b15a.ada @@ -0,0 +1,207 @@ +-- C55B15A.ADA + +-- Grant of Unlimited Rights +-- +-- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687, +-- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained +-- unlimited rights in the software and documentation contained herein. +-- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making +-- this public release, the Government intends to confer upon all +-- recipients unlimited rights equal to those held by the Government. +-- These rights include rights to use, duplicate, release or disclose the +-- released technical data and computer software in whole or in part, in +-- any manner and for any purpose whatsoever, and to have or permit others +-- to do so. +-- +-- DISCLAIMER +-- +-- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR +-- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED +-- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF 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 DISCRETE_RANGE OF THE FORM 'ST RANGE L..R' +-- RAISES AN EXCEPTION BECAUSE L OR R IS A NON-STATIC +-- EXPRESSION WHOSE VALUE IS OUTSIDE THE RANGE OF VALUES +-- ASSOCIATED WITH ST (OR BECAUSE ST'FIRST IS NON-STATIC +-- AND L IS STATIC AND LESS THAN ST'FIRST ; SIMILARLY FOR +-- ST'LAST AND R ), CONTROL DOES NOT ENTER THE LOOP. + +-- *** NOTE: This test has been modified since ACVC version 1.11 to -- 9X +-- *** remove incompatibilities associated with the transition -- 9X +-- *** to Ada 9X. -- 9X +-- *** -- 9X + +-- RM 04/13/81 +-- SPS 11/01/82 +-- BHS 07/13/84 +-- EG 10/28/85 FIX NUMERIC_ERROR/CONSTRAINT_ERROR ACCORDING TO +-- AI-00387. +-- MRM 03/30/93 REMOVED NUMERIC_ERROR FOR 9X COMPATIBILITY +-- GJD 11/15/95 REMOVED CASE OF POTENTIALLY STATICALLY INCOMPATIBLE RANGE. + +WITH SYSTEM; +WITH REPORT; +PROCEDURE C55B15A IS + + USE REPORT ; + +BEGIN + + TEST( "C55B15A" , "WHEN 'FOR I IN ST RANGE L..R LOOP' " & + "RAISES AN EXCEPTION, CONTROL DOES NOT ENTER " & + "THE BODY OF THE LOOP" ); + + ------------------------------------------------------------------- + ----------------- STATIC (SUB)TYPE, DYNAMIC RANGE ----------------- + + DECLARE + + SUBTYPE ST IS INTEGER RANGE 1..4 ; + + FIRST : CONSTANT INTEGER := IDENT_INT( 1) ; + SECOND : CONSTANT INTEGER := IDENT_INT( 2) ; + THIRD : CONSTANT INTEGER := IDENT_INT( 3) ; + FOURTH : CONSTANT INTEGER := IDENT_INT( 4) ; + FIFTH : CONSTANT INTEGER := IDENT_INT( 5) ; + TENTH : CONSTANT INTEGER := IDENT_INT(10) ; + ZEROTH : CONSTANT INTEGER := IDENT_INT( 0) ; + + BEGIN + + BEGIN + + FOR I IN ST RANGE 3..TENTH LOOP + FAILED( "EXCEPTION NOT RAISED (I1)" ); + END LOOP; + + EXCEPTION + + WHEN CONSTRAINT_ERROR => NULL ; + WHEN OTHERS => + FAILED( "WRONG EXCEPTION RAISED (I1)" ); + + END ; + + + BEGIN + + FOR I IN ST RANGE 0..THIRD LOOP + FAILED( "EXCEPTION NOT RAISED (I2)" ); + END LOOP; + + EXCEPTION + + WHEN CONSTRAINT_ERROR => NULL ; + WHEN OTHERS => + FAILED( "WRONG EXCEPTION RAISED (I2)" ); + + END ; + END ; + + + ------------------------------------------------------------------- + ----------------- DYNAMIC (SUB)TYPE, STATIC RANGE ----------------- + + DECLARE + + TYPE ENUM IS ( AMINUS , A,B,C,D,E, F,G,H,I,J ); + + SUBTYPE ST IS ENUM RANGE ENUM'VAL( IDENT_INT( 1) ) .. + ENUM'VAL( IDENT_INT( 4) ) ; + + FIRST : CONSTANT ENUM := A ; + SECOND : CONSTANT ENUM := B ; + THIRD : CONSTANT ENUM := C ; + FOURTH : CONSTANT ENUM := D ; + FIFTH : CONSTANT ENUM := E ; + TENTH : CONSTANT ENUM := J ; + ZEROTH : CONSTANT ENUM := AMINUS ; + + BEGIN + + BEGIN + + FOR I IN ST RANGE C..TENTH LOOP + FAILED( "EXCEPTION NOT RAISED (E1)" ); + END LOOP; + + EXCEPTION + + WHEN CONSTRAINT_ERROR => NULL ; + WHEN OTHERS => + FAILED( "WRONG EXCEPTION RAISED (E1)" ); + + END ; + + + BEGIN + + FOR I IN ST RANGE AMINUS..THIRD LOOP + FAILED( "EXCEPTION NOT RAISED (E2)" ); + END LOOP; + + EXCEPTION + + WHEN CONSTRAINT_ERROR => NULL ; + WHEN OTHERS => + FAILED( "WRONG EXCEPTION RAISED (E2)" ); + + END ; + + END ; + + + DECLARE + + SUBTYPE ST IS CHARACTER RANGE IDENT_CHAR( 'A' ) .. + IDENT_CHAR( 'D' ) ; + + FIRST : CONSTANT CHARACTER := 'A' ; + SECOND : CONSTANT CHARACTER := 'B' ; + THIRD : CONSTANT CHARACTER := 'C' ; + FOURTH : CONSTANT CHARACTER := 'D' ; + FIFTH : CONSTANT CHARACTER := 'E' ; + TENTH : CONSTANT CHARACTER := 'J' ; + ZEROTH : CONSTANT CHARACTER := '0' ;--ZERO; PRECEDES LETTERS + + BEGIN + + BEGIN + + FOR I IN ST RANGE 'C'..TENTH LOOP + FAILED( "EXCEPTION NOT RAISED (C1)" ); + END LOOP; + + EXCEPTION + + WHEN CONSTRAINT_ERROR => NULL ; + WHEN OTHERS => + FAILED( "WRONG EXCEPTION RAISED (C1)" ); + + END ; + + + BEGIN + + FOR I IN ST RANGE '0'..THIRD LOOP -- ZERO..'C' + FAILED( "EXCEPTION NOT RAISED (C2)" ); + END LOOP; + + EXCEPTION + + WHEN CONSTRAINT_ERROR => NULL ; + WHEN OTHERS => + FAILED( "WRONG EXCEPTION RAISED (C2)" ); + + END ; + + END ; + + + RESULT ; + + +END C55B15A ; diff --git a/gcc/testsuite/ada/acats/tests/c5/c55b16a.ada b/gcc/testsuite/ada/acats/tests/c5/c55b16a.ada new file mode 100644 index 000000000..c6bf2b8f1 --- /dev/null +++ b/gcc/testsuite/ada/acats/tests/c5/c55b16a.ada @@ -0,0 +1,101 @@ +-- C55B16A.ADA + +-- Grant of Unlimited Rights +-- +-- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687, +-- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained +-- unlimited rights in the software and documentation contained herein. +-- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making +-- this public release, the Government intends to confer upon all +-- recipients unlimited rights equal to those held by the Government. +-- These rights include rights to use, duplicate, release or disclose the +-- released technical data and computer software in whole or in part, in +-- any manner and for any purpose whatsoever, and to have or permit others +-- to do so. +-- +-- DISCLAIMER +-- +-- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR +-- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED +-- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF 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 PROCESSING OF ITERATIONS OVER AN ENUMERATION TYPE +-- WHOSE (USER-DEFINED) REPRESENTATION CONSISTS OF A NON-CONTIGUOUS +-- SET OF INTEGERS. +-- +-- (INHERITANCE (AND SUBSEQUENT OVERRIDING) OF REPRESENTATION +-- SPECIFICATIONS WILL BE TESTED ELSEWHERE.) + +-- HISTORY: +-- RM 08/06/82 CREATED ORIGINAL TEST. +-- BCB 01/04/88 MODIFIED HEADER. +-- PWB 05/11/89 CHANGED EXTENSION FROM '.DEP' TO '.ADA'. + + +WITH REPORT; USE REPORT; +PROCEDURE C55B16A IS + + I1 : INTEGER := 0 ; + + TYPE ENUM IS ( 'A' , 'B' , 'D' , 'C' , Z , X , D , A , C ); + FOR ENUM USE ( -15 , -14 , -11 , -10 , + 1 , 3 , 4 , 8 , 9 ); + +BEGIN + + TEST ("C55B16A" , "TEST LOOPING OVER ENUMERATION TYPES WITH" & + " NON-CONTIGUOUS REPRESENTATION" ); + + I1 := IDENT_INT(0) ; + + FOR X IN ENUM LOOP + + IF X /= ENUM'VAL(I1) OR + ENUM'POS(X) /= I1 -- 0..8 + THEN + FAILED ( "LOOP_PARAMETER ASCENDING INCORRECTLY (1)" ); + END IF; + + I1 := I1 + IDENT_INT(1) ; + + END LOOP; + + + I1 := IDENT_INT(6) ; + + FOR X IN ENUM RANGE D .. C LOOP + + IF X /= ENUM'VAL(I1) OR + ENUM'POS(X) /= I1 -- 6..8 + THEN + FAILED ( "LOOP_PARAMETER ASCENDING INCORRECTLY (2)" ); + END IF; + + I1 := I1 + IDENT_INT(1) ; + + END LOOP; + + + I1 := IDENT_INT(4) ; + + FOR X IN REVERSE 'A'..ENUM'(Z) LOOP + + IF X /= ENUM'VAL(I1) OR + ENUM'POS(X) /= I1 -- 4..0 + THEN + FAILED ( "LOOP_PARAMETER DESCENDING INCORRECTLY (3)" ); + END IF; + + I1 := I1 - IDENT_INT(1) ; + + END LOOP; + + + RESULT ; + + +END C55B16A ; diff --git a/gcc/testsuite/ada/acats/tests/c5/c55c02a.ada b/gcc/testsuite/ada/acats/tests/c5/c55c02a.ada new file mode 100644 index 000000000..c320edbb2 --- /dev/null +++ b/gcc/testsuite/ada/acats/tests/c5/c55c02a.ada @@ -0,0 +1,49 @@ +-- C55C02A.ADA + +-- Grant of Unlimited Rights +-- +-- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687, +-- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained +-- unlimited rights in the software and documentation contained herein. +-- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making +-- this public release, the Government intends to confer upon all +-- recipients unlimited rights equal to those held by the Government. +-- These rights include rights to use, duplicate, release or disclose the +-- released technical data and computer software in whole or in part, in +-- any manner and for any purpose whatsoever, and to have or permit others +-- to do so. +-- +-- DISCLAIMER +-- +-- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR +-- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED +-- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF 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 WHILE LOOPS WITH FALSE CONDITIONS ARE NEVER EXECUTED. + +-- DAT 1/29/81 +-- DLD 8/06/82 + +WITH REPORT; +PROCEDURE C55C02A IS + + USE REPORT; + +BEGIN + TEST ("C55C02A", "INITIAL FALSE CONDITIONS IN WHILE LOOPS"); + + WHILE FALSE LOOP + FAILED ("STATIC FALSE WHILE LOOP ENTERED"); + EXIT; + END LOOP; + + WHILE IDENT_BOOL (FALSE) LOOP + FAILED ("DYNAMIC FALSE WHILE LOOP ENTERED"); + EXIT; + END LOOP; + + RESULT; +END C55C02A; diff --git a/gcc/testsuite/ada/acats/tests/c5/c55c02b.ada b/gcc/testsuite/ada/acats/tests/c5/c55c02b.ada new file mode 100644 index 000000000..c344838c6 --- /dev/null +++ b/gcc/testsuite/ada/acats/tests/c5/c55c02b.ada @@ -0,0 +1,59 @@ +-- C55C02B.ADA + +-- Grant of Unlimited Rights +-- +-- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687, +-- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained +-- unlimited rights in the software and documentation contained herein. +-- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making +-- this public release, the Government intends to confer upon all +-- recipients unlimited rights equal to those held by the Government. +-- These rights include rights to use, duplicate, release or disclose the +-- released technical data and computer software in whole or in part, in +-- any manner and for any purpose whatsoever, and to have or permit others +-- to do so. +-- +-- DISCLAIMER +-- +-- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR +-- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED +-- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF 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 WHILE CONDITION IS EVALUATED EACH TIME. + +-- DAT 1/29/81 +-- SPS 3/2/83 + +WITH REPORT; +PROCEDURE C55C02B IS + + USE REPORT; + + I : INTEGER := 0; + + FT : ARRAY (FALSE .. TRUE) OF BOOLEAN + := (IDENT_BOOL (FALSE), IDENT_BOOL (TRUE)); + +BEGIN + TEST ("C55C02B", "WHILE CONDITION IS EVALUATED EACH TIME THROUGH"); + + WHILE I /= 10 LOOP + I := I + 1; + END LOOP; + IF I /= 10 THEN + FAILED ("BAD LOOP FLOW - OPTIMIZABLE CONDITION"); + END IF; + + I := 10; + WHILE FT (IDENT_BOOL (I /= 14)) LOOP + I := I + 1; + END LOOP; + IF I /= 14 THEN + FAILED ("BAD LOOP FLOW - DYNAMIC CONDITION"); + END IF; + + RESULT; +END C55C02B; diff --git a/gcc/testsuite/ada/acats/tests/c5/c56002a.ada b/gcc/testsuite/ada/acats/tests/c5/c56002a.ada new file mode 100644 index 000000000..ff368e363 --- /dev/null +++ b/gcc/testsuite/ada/acats/tests/c5/c56002a.ada @@ -0,0 +1,148 @@ +-- C56002A.ADA + +-- Grant of Unlimited Rights +-- +-- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687, +-- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained +-- unlimited rights in the software and documentation contained herein. +-- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making +-- this public release, the Government intends to confer upon all +-- recipients unlimited rights equal to those held by the Government. +-- These rights include rights to use, duplicate, release or disclose the +-- released technical data and computer software in whole or in part, in +-- any manner and for any purpose whatsoever, and to have or permit others +-- to do so. +-- +-- DISCLAIMER +-- +-- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR +-- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED +-- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF 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 BLOCKS CAN HAVE DECLARATIVE PARTS AND THAT +-- THE EFFECT OF THESE DECLARATIONS IS LIMITED TO THE BLOCKS +-- IN WHICH THEY OCCUR. + + +-- RM 04/16/81 +-- SPS 3/4/83 + +WITH REPORT; +PROCEDURE C56002A IS + + USE REPORT ; + +BEGIN + + TEST( "C56002A" , "BLOCKS CAN HAVE DECLARATIVE PARTS AND" & + " THE EFFECT OF THESE DECLARATIONS IS LIMITED" & + " TO THE BLOCKS IN WHICH THEY OCCUR" ) ; + + DECLARE + + FIRST : CONSTANT INTEGER := IDENT_INT( 1) ; + SECOND : CONSTANT INTEGER := IDENT_INT( 2) ; + THIRD : CONSTANT INTEGER := IDENT_INT( 3) ; + FOURTH : CONSTANT INTEGER := IDENT_INT( 4) ; + FIFTH : CONSTANT INTEGER := IDENT_INT( 5) ; + TENTH : CONSTANT INTEGER := IDENT_INT(10) ; + ZEROTH : CONSTANT INTEGER := IDENT_INT( 0) ; + + BEGIN + + IF FIRST /= 1 OR + SECOND /= 2 OR + THIRD /= 3 OR + FOURTH /= 4 OR + FIFTH /= 5 OR + TENTH /=10 OR + ZEROTH /= 0 + THEN + FAILED( "WRONG VALUES - 1" ); + END IF; + + DECLARE + + TYPE ENUM IS ( AMINUS , A,B,C,D,E, F,G,H,I,J ); + + FIRST : CONSTANT ENUM := A ; + SECOND : CONSTANT ENUM := B ; + THIRD : CONSTANT ENUM := C ; + FOURTH : CONSTANT ENUM := D ; + FIFTH : CONSTANT ENUM := E ; + TENTH : CONSTANT ENUM := J ; + ZEROTH : CONSTANT ENUM := AMINUS ; + + BEGIN + + IF FIRST /= ENUM'VAL( IDENT_INT( 1 ) ) OR + SECOND /= ENUM'VAL( IDENT_INT( 2 ) ) OR + THIRD /= ENUM'VAL( IDENT_INT( 3 ) ) OR + FOURTH /= ENUM'VAL( IDENT_INT( 4 ) ) OR + FIFTH /= ENUM'VAL( IDENT_INT( 5 ) ) OR + TENTH /= ENUM'VAL( IDENT_INT(10 ) ) OR + ZEROTH /= ENUM'VAL( IDENT_INT( 0 ) ) + THEN + FAILED( "WRONG VALUES - 2" ); + END IF; + + END ; + + IF FIRST /= 1 OR + SECOND /= 2 OR + THIRD /= 3 OR + FOURTH /= 4 OR + FIFTH /= 5 OR + TENTH /=10 OR + ZEROTH /= 0 + THEN + FAILED( "WRONG VALUES - 3" ); + END IF; + + DECLARE + + FIRST : CONSTANT CHARACTER := 'A' ; + SECOND : CONSTANT CHARACTER := 'B' ; + THIRD : CONSTANT CHARACTER := 'C' ; + FOURTH : CONSTANT CHARACTER := 'D' ; + FIFTH : CONSTANT CHARACTER := 'E' ; + TENTH : CONSTANT CHARACTER := 'J' ; + ZEROTH : CONSTANT CHARACTER := '0' ;--ZERO < ANY LETTER + + BEGIN + + IF FIRST /= IDENT_CHAR( 'A' ) OR + SECOND /= IDENT_CHAR( 'B' ) OR + THIRD /= IDENT_CHAR( 'C' ) OR + FOURTH /= IDENT_CHAR( 'D' ) OR + FIFTH /= IDENT_CHAR( 'E' ) OR + TENTH /= IDENT_CHAR( 'J' ) OR + ZEROTH /= IDENT_CHAR( '0' ) + THEN + FAILED( "WRONG VALUES - 4" ); + END IF; + + END ; + + IF FIRST /= 1 OR + SECOND /= 2 OR + THIRD /= 3 OR + FOURTH /= 4 OR + FIFTH /= 5 OR + TENTH /=10 OR + ZEROTH /= 0 + THEN + FAILED( "WRONG VALUES - 5" ); + END IF; + + + END ; + + + RESULT ; + + +END C56002A ; diff --git a/gcc/testsuite/ada/acats/tests/c5/c57003a.ada b/gcc/testsuite/ada/acats/tests/c5/c57003a.ada new file mode 100644 index 000000000..8ca95e52e --- /dev/null +++ b/gcc/testsuite/ada/acats/tests/c5/c57003a.ada @@ -0,0 +1,334 @@ +-- C57003A.ADA + +-- Grant of Unlimited Rights +-- +-- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687, +-- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained +-- unlimited rights in the software and documentation contained herein. +-- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making +-- this public release, the Government intends to confer upon all +-- recipients unlimited rights equal to those held by the Government. +-- These rights include rights to use, duplicate, release or disclose the +-- released technical data and computer software in whole or in part, in +-- any manner and for any purpose whatsoever, and to have or permit others +-- to do so. +-- +-- DISCLAIMER +-- +-- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR +-- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED +-- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF 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 EXIT STATEMENT IS EVALUATED EACH TIME THROUGH A LOOP, +-- AND THAT IT IS EVALUATED CORRECTLY WHETHER POSITIONED AT THE +-- BEGINNING, MIDDLE, OR END OF THE LOOP. + + + +-- EACH TEST IS A LOOP ON J WHERE THE EXIT CONDITIONS ARE TO EVALUATE +-- TO 'FALSE' A CERTAIN NUMBER OF TIMES UNTIL, AT THE APPROPRIATE +-- TIME, ONE OF THEM EVALUATES TO 'TRUE' AND CAUSES THE LOOP TO BE +-- EXITED. +-- +-- +-- THE TEST IS PERFORMED 30 TIMES FOR EACH OF THE FIRST TWO +-- DATA TYPES CONSIDERED ('INTEGER', USER-DEFINED ENUMERATION) +-- AND 26 TIMES FOR 'CHARACTER' (THUS 86 TIMES ALTOGETHER). +-- +-- +-- EACH DATA TYPE HAS ITS OWN SEPARATE SECTION OF CODE. ALL SECTIONS +-- FOLLOW THE SAME TESTING ALGORITHM (MUTATIS MUTANDIS). THE CALCU- +-- LATIONS WHICH KEEP TRACK OF THE FLOW OF CONTROL ARE ALL DONE IN +-- INTEGER ARITHMETIC. THERE ARE THREE DATA TYPES, THUS THREE +-- SECTIONS. +-- +-- +-- FOR EACH DATA TYPE, THE 30 TESTS ARE DIVIDED INTO 3 "SEGMENTS" +-- +-- << NOTE: THE NUMBER OF SEGMENTS IS WRITTEN " 3 " , +-- THE NUMBER OF SECTIONS IS WRITTEN "THREE" >> +-- +-- (OF 10 TESTS EACH, EXCEPT 10,10,6 FOR 'CHARACTER'), NUMBERED +-- 0 , 1 , 2 AND CORRESPONDING TO THE 3 SIGNIFICANTLY DIFFERENT +-- POSITIONS OF AN EXIT STATEMENT WITH RESPECT TO THE LOOP IT IS IN +-- ( "AT THE VERY TOP" , "AT THE VERY BOTTOM" , "ANYWHERE IN BETWEEN" +-- ). AT THE BEGINNING OF EACH TEST, THE VARIABLE WHICH_SEGMENT +-- IS UPDATED TO CONTAIN THE NEW VALUE OF THIS IDENTIFYING NUMBER +-- (FOR THE TEST ABOUT TO BEGIN): +-- +-- EXIT AT THE TOP ........ WHICH_SEGMENT = 0 +-- EXIT FROM THE MIDDLE ........ WHICH_SEGMENT = 1 +-- EXIT AT THE BOTTOM ........ WHICH_SEGMENT = 2 . +-- +-- +-- WITHIN EACH SECTION, THE TESTS ARE NUMBERED FROM 1 TO 30 +-- (26 FOR 'CHARACTER'). THIS NUMBER IS STORED IN THE INTEGER +-- VARIABLE INT_I (EQUAL TO THE CURRENT VALUE OF THE OUTER-LOOP +-- INDEX WHEN THAT INDEX IS OF INTEGER TYPE), WHOSE APPROPRIATE VALUE +-- FOR EACH TEST IS SET AT THE BEGINNING OF THE TEST. +-- +-- +-- AS PART OF THE EVALUATION PROCESS, THE PROGRAM COMPUTES FOR EACH +-- TEST (I.E. FOR EACH VALUE OF I , OR OF INT_I ) THE APPROPRIATE +-- NUMBER OF INNER-LOOP ITERATIONS REQUIRED BEFORE EXIT; THIS IS +-- THE EXPECTED VALUE OF J (EXPRESSED AS AN INTEGER IN THE RANGE +-- 1..10 ) AND STORES IT IN EXPECTED_J . FOR EACH OF THE THREE +-- SECTIONS, THE TIME SEQUENCE OF THESE 30 VALUES IS +-- +-- 1 2 3 4 5 6 7 8 9 10 << SEGMENT 1 >> +-- 6 6 7 7 8 8 9 9 10 10 << SEGMENT 2 >> +-- 7 8 8 8 9 9 9 10 10 10 << SEGMENT 3 >> +-- +-- (EACH SECTION GETS ALL 3 ROWS, NOT ONE ROW PER SECTION; +-- FOR 'CHARACTER', WHERE ONLY 26 VALUES ARE REQUIRED, THE LAST 4 +-- VALUES ARE OMITTED). THIS NUMBER IS COMPARED WITH THE ACTUAL +-- VALUE OF J (ACTUAL NUMBER OF INNER-LOOP ITERATIONS BEFORE THE +-- EXECUTION OF THE EXIT STATEMENT) AS SAVED JUST BEFORE THE EXIT +-- FROM THE LOOP (AGAIN IN THE FORM OF AN INTEGER IN THE RANGE +-- 1..30 , IRRESPECTIVE OF THE DATA TYPE BEING TESTED), I F +-- SUCH SAVED VALUE IS AVAILABLE. +-- +-- +-- THE ACTUAL VALUE OF INNER-LOOP ITERATIONS (AS SAVED IMMEDIATELY +-- BEFORE THE EXIT, AS OPPOSED TO A VALUE LEFT OVER FROM SOME +-- PREVIOUS ITERATION) IS AVAILABLE ONLY IF WHICH_SEGMENT /= 0 , +-- AND IS THEN STORED IN SAVE_J . +-- +-- +-- FOR THE CASE WHICH_SEGMENT = 0 , THE ITERATIONS ARE COUNTED IN +-- THE VARIABLE COUNT , WHOSE VALUE AT THE COMPLETION OF THE +-- I-TH TEST ( I IN 1..10 ) MUST BE EQUAL TO EXPECTED_J - 1 , +-- AND THUS TO I - 1 (METHODOLOGICALLY AS WELL AS COMPUTATIONALLY +-- THIS IS NO DIFFERENT FROM USING THE MOST RECENT VALUE OF SAVE_J +-- WHEN A CURRENT ONE CANNOT BE OBTAINED). AFTER BEING INCREMENTED +-- BY 1 , COUNT IS CHECKED AGAINST EXPECTED_J . +-- +-- +-- THIS CONCLUDES THE DESCRIPTION OF THE CASE WHICH_SEGMENT = 0 , +-- AND THUS OF THE ALGORITHM. THE ONLY REASON FOR SPLITTING THE +-- CASE WHICH_SEGMENT /= 0 INTO TWO IS THE DESIRE TO PROVIDE FOR +-- DISTINCT MESSAGES. + + + +-- RM 04/23/81 +-- SPS 3/7/83 + +WITH REPORT; +PROCEDURE C57003A IS + + USE REPORT ; + +BEGIN + + TEST( "C57003A" , "TEST THAT THE EXIT STATEMENT IS EVALUATED" & + " EACH TIME THROUGH THE LOOP" ); + + DECLARE + + WHICH_SEGMENT : INTEGER RANGE 0..2 ; -- BOUNDS ARE TIGHT + SAVE_J : INTEGER RANGE 1..10 ; + EXPECTED_J : INTEGER RANGE 1..10 ; + COUNT : INTEGER RANGE 0..100 := 0 ; + INT_I : INTEGER RANGE 1..30 ; + + TYPE ENUM IS ( CHANGE_THE_ORIGIN_FROM_0_TO_1 , + + A1 , A2 , A3 , A4 , A5 , A6 , A7 , A8 , A9 , A10 , + A11, A12, A13, A14, A15, A16, A17, A18, A19, A20 , + A21, A22, A23, A24, A25, A26, A27, A28, A29, A30 ); + + BEGIN + + + -------------------------------------------------------------- + ----------------------- INTEGER ---------------------------- + + + FOR I IN INTEGER RANGE 1..30 LOOP + + + WHICH_SEGMENT := ( I - 1 ) / 10 ; + EXPECTED_J := ( I + WHICH_SEGMENT ) / + ( WHICH_SEGMENT + 1 ) ; + + COUNT := 0 ; + + + FOR J IN INTEGER RANGE 1..10 LOOP + + -- J NOT SAVED HERE (SO THAT 'EXIT' BE FIRST STMT) + + EXIT WHEN WHICH_SEGMENT = 0 AND + 1*J >= I ;--COUNT+:=1 ON NXT LINE INSTEAD + COUNT := COUNT + 1 ; + + NULL ; + NULL ; + NULL ; + SAVE_J := J ; + EXIT WHEN WHICH_SEGMENT = 1 AND + 2*J >= I ; + + NULL ; + NULL ; + NULL ; + SAVE_J := J ; + EXIT WHEN WHICH_SEGMENT = 2 AND + 3*J >= I ; + + END LOOP; + + + COUNT := COUNT + 1 ; -- SEE HEADER + + CASE WHICH_SEGMENT IS + WHEN 0 => + IF COUNT /= EXPECTED_J THEN + FAILED( "WRONG COUNT; INT, EXIT AT TOP" ); + END IF; + WHEN 1 => -- WOULD WORK ALSO FOR 0 + IF SAVE_J /= EXPECTED_J THEN + FAILED( "WRONG COUNT; I,EXIT AT MIDDLE" ); + END IF; + WHEN 2 => + IF SAVE_J /= EXPECTED_J THEN + FAILED( "WRONG COUNT; I,EXIT AT BOTTOM" ); + END IF; + END CASE; + + END LOOP; + + + + -------------------------------------------------------------- + ---------------------- CHARACTER --------------------------- + + + FOR I IN CHARACTER RANGE 'A'..'Z' LOOP + + INT_I := CHARACTER'POS(I) - CHARACTER'POS('A') + 1; + + WHICH_SEGMENT := ( INT_I - 1 ) / 10 ; + EXPECTED_J := ( INT_I + WHICH_SEGMENT ) / + ( WHICH_SEGMENT + 1 ) ; + + COUNT := 0 ; + + + FOR J IN CHARACTER RANGE 'A'..'J' LOOP + + -- J NOT SAVED HERE (SO THAT 'EXIT' BE FIRST STMT) + + EXIT WHEN WHICH_SEGMENT = 0 AND + J >= I ; -- COUNT+:=1 ON NXT LINE INSTEAD + COUNT := COUNT + 1 ; + + NULL ; + NULL ; + NULL ; + SAVE_J := CHARACTER'POS(J) - CHARACTER'POS('A') + 1; + EXIT WHEN WHICH_SEGMENT = 1 AND + 2 * SAVE_J >= INT_I ; + + NULL ; + NULL ; + NULL ; + EXIT WHEN WHICH_SEGMENT = 2 AND + 3 * SAVE_J >= INT_I ; + + END LOOP; + + + COUNT := COUNT + 1 ; + + CASE WHICH_SEGMENT IS + WHEN 0 => + IF COUNT /= EXPECTED_J THEN + FAILED( "WRONG COUNT;CHAR, EXIT AT TOP" ); + END IF; + WHEN 1 => -- WOULD WORK ALSO FOR 0 + IF SAVE_J /= EXPECTED_J THEN + FAILED( "WRONG COUNT; C,EXIT AT MIDDLE" ); + END IF; + WHEN 2 => + IF SAVE_J /= EXPECTED_J THEN + FAILED( "WRONG COUNT; C,EXIT AT BOTTOM" ); + END IF; + END CASE; + + END LOOP; + + + + -------------------------------------------------------------- + --------------------- ENUMERATION -------------------------- + + + FOR I IN ENUM RANGE A1..A30 LOOP + + + INT_I := ENUM'POS(I) ; + + WHICH_SEGMENT := ( INT_I - 1 ) / 10 ; + EXPECTED_J := ( INT_I + WHICH_SEGMENT ) / + ( WHICH_SEGMENT + 1 ) ; + + COUNT := 0 ; + + + FOR J IN ENUM RANGE A1..A10 LOOP + + -- J NOT SAVED HERE (SO THAT 'EXIT' BE FIRST STMT) + + EXIT WHEN WHICH_SEGMENT = 0 AND + J >= I ; -- COUNT+:=1 ON NXT LINE INSTEAD + COUNT := COUNT + 1 ; + + NULL ; + NULL ; + NULL ; + SAVE_J := ENUM'POS(J) ; + EXIT WHEN WHICH_SEGMENT = 1 AND + 2 * SAVE_J >= INT_I ; + + NULL ; + NULL ; + NULL ; + EXIT WHEN WHICH_SEGMENT = 2 AND + 3 * SAVE_J >= INT_I ; + + END LOOP; + + + COUNT := COUNT + 1 ; + + CASE WHICH_SEGMENT IS + WHEN 0 => + IF COUNT /= EXPECTED_J THEN + FAILED( "WRONG COUNT;ENUM, EXIT AT TOP" ); + END IF; + WHEN 1 => -- WOULD WORK ALSO FOR 0 + IF SAVE_J /= EXPECTED_J THEN + FAILED( "WRONG COUNT; E,EXIT AT MIDDLE" ); + END IF; + WHEN 2 => + IF SAVE_J /= EXPECTED_J THEN + FAILED( "WRONG COUNT; E,EXIT AT BOTTOM" ); + END IF; + END CASE; + + END LOOP; + + -------------------------------------------------------------- + + END ; + + + RESULT ; + + +END C57003A ; diff --git a/gcc/testsuite/ada/acats/tests/c5/c57004a.ada b/gcc/testsuite/ada/acats/tests/c5/c57004a.ada new file mode 100644 index 000000000..352528b92 --- /dev/null +++ b/gcc/testsuite/ada/acats/tests/c5/c57004a.ada @@ -0,0 +1,160 @@ +-- C57004A.ADA + +-- Grant of Unlimited Rights +-- +-- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687, +-- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained +-- unlimited rights in the software and documentation contained herein. +-- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making +-- this public release, the Government intends to confer upon all +-- recipients unlimited rights equal to those held by the Government. +-- These rights include rights to use, duplicate, release or disclose the +-- released technical data and computer software in whole or in part, in +-- any manner and for any purpose whatsoever, and to have or permit others +-- to do so. +-- +-- DISCLAIMER +-- +-- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR +-- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED +-- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF 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 EXIT STATEMENT WITH A LOOP NAME TERMINATES EXECUTION +-- OF THE LOOP STATEMENT WHOSE NAME IT MENTIONS, AND OF ALL OTHER +-- LOOP STATEMENTS (IF ANY) INTERIOR TO THE FIRST LOOP AND ENCLOSING +-- THE EXIT STATEMENT. + +-- CASE 1 : UNCONDITIONAL EXITS. + + +-- RM 04/24/81 +-- SPS 3/7/83 + +WITH REPORT; +PROCEDURE C57004A IS + + USE REPORT ; + +BEGIN + + TEST( "C57004A" , "CHECK THAT A NAMING EXIT STATEMENT TERMINATES" & + " EXECUTION OF THE NAMED LOOP AND OF ALL LOOPS" & + " SITUATED IN-BETWEEN" ); + + DECLARE + + COUNT : INTEGER := 0 ; + + BEGIN + + OUTERMOST : + FOR X IN INTEGER RANGE 1..2 LOOP + + FOR Y IN INTEGER RANGE 1..2 LOOP + + COMMENT( "BEFORE 1" ); + + LOOP1 : + FOR I IN 1..10 LOOP + COMMENT( "INSIDE 1" ); + EXIT LOOP1 ; + FAILED( "EXIT NOT OBEYED (1)" ); + FOR J IN 1..10 LOOP + FAILED( "OUTER EXIT NOT OBEYED (1)" ); + EXIT ; + FAILED( "BOTH EXITS IGNORED (1)" ); + END LOOP; + END LOOP LOOP1 ; + + + COMMENT( "BEFORE 2" ); + COUNT := COUNT + 1 ; + + LOOP2 : + FOR A IN 1..1 LOOP + FOR B IN 1..1 LOOP + + FOR I IN CHARACTER LOOP + COMMENT( "INSIDE 2" ); + EXIT LOOP2 ; + FAILED( "EXIT NOT OBEYED (2)" ); + FOR J IN BOOLEAN LOOP + FAILED( "OUTER EXIT NOT " & + "OBEYED (2)"); + EXIT ; + FAILED( "BOTH EXITS IGNORED " & + "(2)"); + END LOOP; + END LOOP; + + END LOOP; + END LOOP LOOP2 ; + + + COMMENT( "BEFORE 3" ); + COUNT := COUNT + 1 ; + + LOOP3 : + FOR A IN 1..1 LOOP + FOR B IN 1..1 LOOP + + FOR I IN BOOLEAN LOOP + COMMENT( "INSIDE 3" ); + BEGIN + EXIT LOOP3 ; + FAILED( "EXIT NOT OBEYED (3)" ); + END ; + FAILED( "EXIT NOT OBEYED (3BIS)" ); + END LOOP; + + END LOOP; + END LOOP LOOP3 ; + + + COMMENT( "BEFORE 4" ); + COUNT := COUNT + 1 ; + + LOOP4 : + FOR A IN 1..1 LOOP + FOR B IN 1..1 LOOP + + + FOR I IN INTEGER RANGE 1..10 LOOP + COMMENT( "INSIDE 4" ); + CASE A IS + WHEN 1 => + EXIT LOOP4 ; + FAILED("EXIT NOT OBEYED " & + "(4)" ); + END CASE; + FAILED( "EXIT NOT OBEYED (4BIS)" ); + END LOOP; + + END LOOP; + END LOOP LOOP4 ; + + + COMMENT( "AFTER 4" ); + COUNT := COUNT + 1 ; + EXIT OUTERMOST ; + + END LOOP; + + FAILED( "MISSED FINAL EXIT" ); + + END LOOP OUTERMOST ; + + + IF COUNT /= 4 THEN + FAILED( "WRONG FLOW OF CONTROL" ); + END IF; + + END ; + + RESULT ; + + +END C57004A ; diff --git a/gcc/testsuite/ada/acats/tests/c5/c57004b.ada b/gcc/testsuite/ada/acats/tests/c5/c57004b.ada new file mode 100644 index 000000000..63f5760ca --- /dev/null +++ b/gcc/testsuite/ada/acats/tests/c5/c57004b.ada @@ -0,0 +1,162 @@ +-- C57004B.ADA + +-- Grant of Unlimited Rights +-- +-- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687, +-- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained +-- unlimited rights in the software and documentation contained herein. +-- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making +-- this public release, the Government intends to confer upon all +-- recipients unlimited rights equal to those held by the Government. +-- These rights include rights to use, duplicate, release or disclose the +-- released technical data and computer software in whole or in part, in +-- any manner and for any purpose whatsoever, and to have or permit others +-- to do so. +-- +-- DISCLAIMER +-- +-- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR +-- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED +-- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF 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 EXIT STATEMENT WITH A LOOP NAME TERMINATES EXECUTION +-- OF THE LOOP STATEMENT WHOSE NAME IT MENTIONS, AND OF ALL OTHER +-- LOOP STATEMENTS (IF ANY) INTERIOR TO THE FIRST LOOP AND ENCLOSING +-- THE EXIT STATEMENT. + +-- CASE 2 : CONDITIONAL EXITS. + + +-- RM 04/27/81 +-- SPS 3/7/83 + +WITH REPORT; +PROCEDURE C57004B IS + + USE REPORT ; + +BEGIN + + TEST( "C57004B" , "CHECK THAT A NAMING EXIT STATEMENT TERMINATES" & + " EXECUTION OF THE NAMED LOOP AND OF ALL LOOPS" & + " SITUATED IN-BETWEEN" ); + + DECLARE + + COUNT : INTEGER := 0 ; + + BEGIN + + OUTERMOST : + FOR X IN INTEGER RANGE 1..2 LOOP + + FOR Y IN INTEGER RANGE 1..2 LOOP + + COMMENT( "BEFORE 1" ); + + LOOP1 : + FOR I IN 1..10 LOOP + COMMENT( "INSIDE 1" ); + EXIT LOOP1 WHEN EQUAL(1,1) ; + FAILED( "EXIT NOT OBEYED (1)" ); + FOR J IN 1..10 LOOP + FAILED( "OUTER EXIT NOT OBEYED (1)" ); + EXIT WHEN EQUAL(1,1) ; + FAILED( "BOTH EXITS IGNORED (1)" ); + END LOOP; + END LOOP LOOP1 ; + + + COMMENT( "BEFORE 2" ); + COUNT := COUNT + 1 ; + + LOOP2 : + FOR A IN 1..1 LOOP + FOR B IN 1..1 LOOP + + FOR I IN CHARACTER LOOP + COMMENT( "INSIDE 2" ); + EXIT LOOP2 WHEN EQUAL(1,1) ; + FAILED( "EXIT NOT OBEYED (2)" ); + FOR J IN BOOLEAN LOOP + FAILED( "OUTER EXIT NOT " & + "OBEYED (2)"); + EXIT WHEN EQUAL(1,1) ; + FAILED( "BOTH EXITS IGNORED " & + "(2)"); + END LOOP; + END LOOP; + + END LOOP; + END LOOP LOOP2 ; + + + COMMENT( "BEFORE 3" ); + COUNT := COUNT + 1 ; + + LOOP3 : + FOR A IN 1..1 LOOP + FOR B IN 1..1 LOOP + + FOR I IN BOOLEAN LOOP + COMMENT( "INSIDE 3" ); + BEGIN + EXIT LOOP3 WHEN EQUAL(1,1) ; + FAILED( "EXIT NOT OBEYED (3)" ); + END ; + FAILED( "EXIT NOT OBEYED (3BIS)" ); + END LOOP; + + END LOOP; + END LOOP LOOP3 ; + + + COMMENT( "BEFORE 4" ); + COUNT := COUNT + 1 ; + + LOOP4 : + FOR A IN 1..1 LOOP + FOR B IN 1..1 LOOP + + + FOR I IN INTEGER RANGE 1..10 LOOP + COMMENT( "INSIDE 4" ); + CASE A IS + WHEN 1 => + EXIT LOOP4 WHEN EQUAL(1,1); + FAILED("EXIT NOT OBEYED " & + "(4)" ); + END CASE; + FAILED( "EXIT NOT OBEYED (4BIS)" ); + END LOOP; + + END LOOP; + END LOOP LOOP4 ; + + + COMMENT( "AFTER 4" ); + COUNT := COUNT + 1 ; + EXIT OUTERMOST ; + + END LOOP; + + FAILED( "MISSED FINAL EXIT" ); + + END LOOP OUTERMOST ; + + + IF COUNT /= 4 THEN + FAILED( "WRONG FLOW OF CONTROL" ); + END IF; + + + END ; + + + RESULT ; + + +END C57004B ; diff --git a/gcc/testsuite/ada/acats/tests/c5/c58004c.ada b/gcc/testsuite/ada/acats/tests/c5/c58004c.ada new file mode 100644 index 000000000..dcb66e091 --- /dev/null +++ b/gcc/testsuite/ada/acats/tests/c5/c58004c.ada @@ -0,0 +1,86 @@ +-- C58004C.ADA + +-- Grant of Unlimited Rights +-- +-- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687, +-- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained +-- unlimited rights in the software and documentation contained herein. +-- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making +-- this public release, the Government intends to confer upon all +-- recipients unlimited rights equal to those held by the Government. +-- These rights include rights to use, duplicate, release or disclose the +-- released technical data and computer software in whole or in part, in +-- any manner and for any purpose whatsoever, and to have or permit others +-- to do so. +-- +-- DISCLAIMER +-- +-- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR +-- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED +-- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF 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 RETURN STATEMENT WORKS FOR RECURSIVE SUBPROGRAMS, +-- BOTH FUNCTIONS AND PROCEDURES. + +-- DCB 2/8/80 +-- SPS 3/7/83 +-- JBG 5/17/83 + +WITH REPORT; +PROCEDURE C58004C IS + + USE REPORT; + + I1, I2 : INTEGER := 0; -- INITIAL VALUE IS IMMATERIAL + + PROCEDURE FACTORIALP (IP1 : IN INTEGER; IP2 : IN OUT INTEGER) IS + + BEGIN + IF IP1 = 1 THEN + IP2 := 1; + RETURN; + ELSE FACTORIALP (IP1 - 1, IP2); + IP2 := IP1 * IP2; + RETURN; + END IF; + + IP2 := 0; + + END FACTORIALP; + + FUNCTION FACTORIALF (IF1 : INTEGER) RETURN INTEGER IS + + BEGIN + IF IF1 = 1 THEN RETURN (1); + END IF; + + RETURN (IF1 * FACTORIALF(IF1 - 1) ); + + END FACTORIALF; + +BEGIN + TEST ("C58004C", "CHECK THAT THE RETURN STATEMENT WORKS FOR" & + " RECURSIVE FUNCTIONS AND PROCEDURES"); + + I1 := FACTORIALF (5); + + IF I1 /= 120 THEN + FAILED ("RETURN STATEMENT IN RECURSIVE FUNCTION NOT " & + "WORKING"); + END IF; + + FACTORIALP (5, I2); + + IF I2 = 0 THEN + FAILED ("RETURN STATEMENT IN RECURSIVE PROCEDURE NOT " & + "WORKING"); + ELSIF I2 /= 120 THEN + FAILED + ("RETURN STMT IN RECURSIVE PROCEDURE NOT WORKING CORRECTLY"); + END IF; + + RESULT; +END C58004C; diff --git a/gcc/testsuite/ada/acats/tests/c5/c58004d.ada b/gcc/testsuite/ada/acats/tests/c5/c58004d.ada new file mode 100644 index 000000000..c4e3ffb44 --- /dev/null +++ b/gcc/testsuite/ada/acats/tests/c5/c58004d.ada @@ -0,0 +1,90 @@ +-- C58004D.ADA + +-- Grant of Unlimited Rights +-- +-- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687, +-- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained +-- unlimited rights in the software and documentation contained herein. +-- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making +-- this public release, the Government intends to confer upon all +-- recipients unlimited rights equal to those held by the Government. +-- These rights include rights to use, duplicate, release or disclose the +-- released technical data and computer software in whole or in part, in +-- any manner and for any purpose whatsoever, and to have or permit others +-- to do so. +-- +-- DISCLAIMER +-- +-- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR +-- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED +-- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF 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 RETURN STATEMENT TERMINATES EXECUTION +-- OF THE INNERMOST ENCLOSING SUBPROGRAM. + +-- CHECKS GENERIC SUBPROGRAMS. + +-- SPS 3/7/83 +-- JRK 1/31/84 + +WITH REPORT; +PROCEDURE C58004D IS + + USE REPORT; + + I1, I2 : INTEGER; + + GENERIC + PROCEDURE ADDM (IA1 : IN OUT INTEGER; IA2 : IN INTEGER); + + PROCEDURE ADDM (IA1 : IN OUT INTEGER; IA2 : IN INTEGER) IS + + GENERIC + PROCEDURE MULT (IM1 : IN OUT INTEGER; IM2 : IN INTEGER); + + PROCEDURE MULT (IM1 : IN OUT INTEGER; IM2 : IN INTEGER) IS + BEGIN + IM1 := IM1 * IM2; + + IF IM1 > 0 THEN RETURN; + END IF; + + IM1 := 0; + END MULT; + + PROCEDURE MLT IS NEW MULT; + + BEGIN + MLT (IA1, IA2); + IA1 := IA1 + IA2; + + IF IA1 > 0 THEN RETURN; + END IF; + + IA1 := 0; + END ADDM; + + PROCEDURE ADM IS NEW ADDM; + +BEGIN + TEST ("C58004D","CHECK THAT RETURN TERMINATES EXECUTION OF ONLY" & + " THE INNERMOST ENCLOSING GENERIC SUBPROGRAM"); + + I1 := 2; + I2 := 3; + ADM (I1,I2); -- SAME AS I1 := (I1 * I2) + I2 + + IF I1 = 0 THEN + FAILED ("RETURN DOES NOT TERMINATE SUBPROGRAM"); + ELSIF I1 = 6 THEN + FAILED + ("RETURN TERMINATES ALL SUBPROGRAMS NOT JUST INNERMOST"); + ELSIF I1 /= 9 THEN + FAILED ("RETURN STATEMENT NOT WORKING CORRECTLY"); + END IF; + + RESULT; +END C58004D; diff --git a/gcc/testsuite/ada/acats/tests/c5/c58004g.ada b/gcc/testsuite/ada/acats/tests/c5/c58004g.ada new file mode 100644 index 000000000..945920a9e --- /dev/null +++ b/gcc/testsuite/ada/acats/tests/c5/c58004g.ada @@ -0,0 +1,95 @@ +-- C58004G.ADA + +-- Grant of Unlimited Rights +-- +-- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687, +-- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained +-- unlimited rights in the software and documentation contained herein. +-- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making +-- this public release, the Government intends to confer upon all +-- recipients unlimited rights equal to those held by the Government. +-- These rights include rights to use, duplicate, release or disclose the +-- released technical data and computer software in whole or in part, in +-- any manner and for any purpose whatsoever, and to have or permit others +-- to do so. +-- +-- DISCLAIMER +-- +-- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR +-- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED +-- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF 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 RETURN STATEMENT WORKS FOR RECURSIVE SUBPROGRAMS, +-- BOTH FUNCTIONS AND PROCEDURES. + +-- CHECK GENERIC SUBPROGRAMS. + +-- SPS 3/7/83 +-- JBG 9/13/83 + +WITH REPORT; +PROCEDURE C58004G IS + + USE REPORT; + + I1, I2 : INTEGER := 0; + + GENERIC + PROCEDURE FACTORIALP (IP1 : IN INTEGER; IP2 : IN OUT INTEGER); + + GENERIC + FUNCTION FACTORIALF (IF1: INTEGER) RETURN INTEGER; + + PROCEDURE FACTORIALP (IP1 : IN INTEGER; IP2 : IN OUT INTEGER) IS + BEGIN + IF IP1 = 1 THEN + IP2 := 1; + RETURN; + ELSE FACTORIALP (IP1 - 1, IP2); + IP2 := IP1 * IP2; + RETURN; + END IF; + + IP2 := 0; + + END FACTORIALP; + + FUNCTION FACTORIALF (IF1 : INTEGER) RETURN INTEGER IS + + BEGIN + IF IF1 = 1 THEN RETURN (1); + END IF; + + RETURN (IF1 * FACTORIALF(IF1 - 1) ); + + END FACTORIALF; + + PROCEDURE FACTP IS NEW FACTORIALP; + FUNCTION FACTF IS NEW FACTORIALF; + +BEGIN + TEST ("C58004G", "CHECK THAT THE RETURN STATEMENT WORKS FOR" & + " RECURSIVE GENERIC FUNCTIONS AND PROCEDURES"); + + I1 := FACTF (5); + + IF I1 /= 120 THEN + FAILED ("RETURN STATEMENT IN RECURSIVE FUNCTION NOT " & + "WORKING"); + END IF; + + FACTP (5, I2); + + IF I2 = 0 THEN + FAILED ("RETURN STATEMENT IN RECURSIVE PROCEDURE NOT " & + "WORKING"); + ELSIF I2 /= 120 THEN + FAILED + ("RETURN STMT IN RECURSIVE PROCEDURE NOT WORKING CORRECTLY"); + END IF; + + RESULT; +END C58004G; diff --git a/gcc/testsuite/ada/acats/tests/c5/c58005a.ada b/gcc/testsuite/ada/acats/tests/c5/c58005a.ada new file mode 100644 index 000000000..ef6b16487 --- /dev/null +++ b/gcc/testsuite/ada/acats/tests/c5/c58005a.ada @@ -0,0 +1,121 @@ +-- C58005A.ADA + +-- Grant of Unlimited Rights +-- +-- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687, +-- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained +-- unlimited rights in the software and documentation contained herein. +-- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making +-- this public release, the Government intends to confer upon all +-- recipients unlimited rights equal to those held by the Government. +-- These rights include rights to use, duplicate, release or disclose the +-- released technical data and computer software in whole or in part, in +-- any manner and for any purpose whatsoever, and to have or permit others +-- to do so. +-- +-- DISCLAIMER +-- +-- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR +-- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED +-- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE +-- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE +-- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A +-- PARTICULAR PURPOSE OF SAID MATERIAL. +--* +-- CHECK THAT WHEN A FUNCTION IS READY TO RETURN CONTROL TO ITS INVOKER +-- THE CONSTRAINTS ON THE RETURN VALUES ARE CHECKED, AND THAT +-- CONSTRAINT ERROR IS THEN RAISED IF AND ONLY IF THE CONSTRAINTS +-- ARE NOT SATISFIED. + +-- THIS TEST CHECKS THAT THE EXCEPTION IS RAISED UNDER THE APPROPRIATE +-- CONDITIONS; IT ALSO CHECKS THE IDENTITY OF THE EXCEPTION. THE +-- PRECISE MOMENT AND PLACE THE EXCEPTION IS RAISED IS TESTED +-- ELSEWHERE. + + +-- RM 05/14/81 +-- SPS 10/26/82 + +WITH REPORT; +PROCEDURE C58005A IS + + USE REPORT ; + + INTVAR : INTEGER ; + +BEGIN + + TEST( "C58005A" , "CHECK THAT EXCEPTIONS ARE RAISED BY A RETURN" & + " STATEMENT IF AND ONLY IF THE CONSTRAINTS ARE" & + " VIOLATED" ); + + + DECLARE + SUBTYPE I1 IS INTEGER RANGE -10..90; + SUBTYPE I2 IS INTEGER RANGE 1..10; + FUNCTION FN1( X : I1 ) + RETURN I2 IS + BEGIN + RETURN 0 ; + END FN1 ; + + FUNCTION FN2( X : I1 ) + RETURN I2 IS + BEGIN + RETURN X + IDENT_INT(0) ; + END FN2 ; + + FUNCTION FN3( X : I1 ) + RETURN I2 IS + HUNDRED : INTEGER RANGE -100..100 := IDENT_INT(100) ; + BEGIN + RETURN HUNDRED - 90 ; + END FN3 ; + + BEGIN + + INTVAR := 0 ; + + BEGIN + INTVAR := FN1( 0 ) + INTVAR ; -- EXCEPTION. + FAILED( "EXCEPTION NOT RAISED - 1" ); + EXCEPTION + WHEN CONSTRAINT_ERROR => INTVAR := INTVAR + 10 ; + WHEN OTHERS => FAILED( "WRONG EXCEPTION RAISED - 1" ) ; + END ; + + BEGIN + INTVAR := FN2( 1 ) + INTVAR ; -- 10+1=11 -- NO EXCEPTION. + INTVAR := INTVAR + 100 ; -- 11+100=111 + EXCEPTION + WHEN OTHERS => FAILED( "EXCEPTION RAISED - 2" ) ; + END ; + + BEGIN + INTVAR := FN2(11 ) + INTVAR ; -- EXCEPTION. + FAILED( "EXCEPTION NOT RAISED - 3" ); + EXCEPTION + WHEN CONSTRAINT_ERROR => INTVAR := INTVAR + 10 ; -- 121 + WHEN OTHERS => FAILED( "WRONG EXCEPTION RAISED - 3" ) ; + END ; + + BEGIN + INTVAR := FN3( 0 ) + INTVAR ;--121+10=131 --NO EXCEPTION. + INTVAR := INTVAR + 1000 ;-- 131+1000=1131 + EXCEPTION + WHEN OTHERS => FAILED( "EXCEPTION RAISED - 4" ) ; + END ; + + + END ; + + + IF INTVAR /= 1131 THEN + FAILED("WRONG FLOW OF CONTROL" ); + END IF; + + + RESULT ; + + +END C58005A; diff --git a/gcc/testsuite/ada/acats/tests/c5/c58005b.ada b/gcc/testsuite/ada/acats/tests/c5/c58005b.ada new file mode 100644 index 000000000..05cda7093 --- /dev/null +++ b/gcc/testsuite/ada/acats/tests/c5/c58005b.ada @@ -0,0 +1,94 @@ +-- C58005B.ADA + +-- Grant of Unlimited Rights +-- +-- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687, +-- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained +-- unlimited rights in the software and documentation contained herein. +-- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making +-- this public release, the Government intends to confer upon all +-- recipients unlimited rights equal to those held by the Government. +-- These rights include rights to use, duplicate, release or disclose the +-- released technical data and computer software in whole or in part, in +-- any manner and for any purpose whatsoever, and to have or permit others +-- to do so. +-- +-- DISCLAIMER +-- +-- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR +-- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED +-- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE +-- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE +-- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A +-- PARTICULAR PURPOSE OF SAID MATERIAL. +--* +-- CHECK THAT WHEN A GENERIC FUNCTION IS READY TO RETURN CONTROL TO ITS +-- INVOKER THE CONSTRAINTS ON THE RETURN VALUES ARE CHECKED, AND THAT +-- CONSTRAINT ERROR IS THEN RAISED IF AND ONLY IF THE CONSTRAINTS +-- ARE NOT SATISFIED. + +-- THIS TEST CHECKS THAT THE EXCEPTION IS RAISED UNDER THE APPROPRIATE +-- CONDITIONS; IT ALSO CHECKS THE IDENTITY OF THE EXCEPTION. THE +-- PRECISE MOMENT AND PLACE THE EXCEPTION IS RAISED IS TESTED +-- ELSEWHERE. + +-- SPS 3/10/83 +-- JBG 9/13/83 +-- AH 8/29/86 ADDED CALLS TO "FAILED" AFTER "IF" STATEMENTS. + +WITH REPORT; +PROCEDURE C58005B IS + + USE REPORT; + +BEGIN + + TEST( "C58005B" , "CHECK THAT EXCEPTIONS ARE RAISED BY A RETURN" & + " STATEMENT IF AND ONLY IF THE CONSTRAINTS ARE" & + " VIOLATED" ); + + + DECLARE + SUBTYPE I1 IS INTEGER RANGE -10..90; + SUBTYPE I2 IS INTEGER RANGE 1..10; + + GENERIC + FUNCTION FN1 ( X : I1 ) RETURN I2; + + FUNCTION FN1( X : I1 ) + RETURN I2 IS + BEGIN + RETURN X; + END FN1; + + FUNCTION F1 IS NEW FN1; + + BEGIN + + BEGIN + IF F1(IDENT_INT(0)) IN I2 THEN + FAILED( "EXCEPTION NOT RAISED - 1A" ); + ELSE + FAILED( "EXCEPTION NOT RAISED - 1B" ); + END IF; + EXCEPTION + WHEN CONSTRAINT_ERROR => NULL; + WHEN OTHERS => FAILED( "WRONG EXCEPTION RAISED - 1" ); + END; + + BEGIN + IF F1(IDENT_INT(11)) IN I2 THEN + FAILED( "EXCEPTION NOT RAISED - 2A" ); + ELSE + FAILED( "EXCEPTION NOT RAISED - 2B" ); + END IF; + EXCEPTION + WHEN CONSTRAINT_ERROR => NULL; + WHEN OTHERS => FAILED( "WRONG EXCEPTION RAISED - 2" ); + END; + + END; + + RESULT; + +END C58005B; diff --git a/gcc/testsuite/ada/acats/tests/c5/c58005h.ada b/gcc/testsuite/ada/acats/tests/c5/c58005h.ada new file mode 100644 index 000000000..276d34d69 --- /dev/null +++ b/gcc/testsuite/ada/acats/tests/c5/c58005h.ada @@ -0,0 +1,172 @@ +-- C58005H.ADA + +-- Grant of Unlimited Rights +-- +-- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687, +-- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained +-- unlimited rights in the software and documentation contained herein. +-- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making +-- this public release, the Government intends to confer upon all +-- recipients unlimited rights equal to those held by the Government. +-- These rights include rights to use, duplicate, release or disclose the +-- released technical data and computer software in whole or in part, in +-- any manner and for any purpose whatsoever, and to have or permit others +-- to do so. +-- +-- DISCLAIMER +-- +-- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR +-- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED +-- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF 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 CONSTRAINTS ON THE RETURN VALUE OF A FUNCTION ARE +-- SATISIFIED WHEN THE FUNCTION RETURNS CONTROL TO ITS INVOKER. + +-- THIS TESTS CHECKS FOR CONSTRAINTS ON CONSTRAINED ACCESS TYPES WITH +-- RECORD, ARRAY, PRIVATE AND LIMITED PRIVATE DESIGNATED TYPES. + +-- SPS 3/10/83 +-- RLB 6/29/01 - Repaired test to work in the face of aggressive optimizations. +-- The objects must be used, and must be tied somehow to the +-- calls to Failed. + +WITH REPORT; +USE REPORT; +PROCEDURE C58005H IS + + PACKAGE PACK IS + TYPE PV (D : NATURAL) IS PRIVATE; + TYPE LP (D : NATURAL) IS LIMITED PRIVATE; + PRIVATE + TYPE PV (D : NATURAL) IS RECORD + NULL; + END RECORD; + TYPE LP (D : NATURAL) IS RECORD + NULL; + END RECORD; + END PACK; + + USE PACK; + + TYPE ARR IS ARRAY (NATURAL RANGE <>) OF NATURAL; + TYPE REC (D : NATURAL) IS RECORD + NULL; + END RECORD; + + TYPE ACC_REC IS ACCESS REC; + TYPE ACC_ARR IS ACCESS ARR; + TYPE ACC_PV IS ACCESS PV; + TYPE ACC_LP IS ACCESS LP; + + SUBTYPE ACC_REC1 IS ACC_REC (D => 1); + SUBTYPE ACC_REC2 IS ACC_REC (D => 2); + + SUBTYPE ACC_ARR1 IS ACC_ARR (1 .. 10); + SUBTYPE ACC_ARR2 IS ACC_ARR (2 .. 5); + + SUBTYPE ACC_PV1 IS ACC_PV (D => 1); + SUBTYPE ACC_PV2 IS ACC_PV (D => 2); + + SUBTYPE ACC_LP1 IS ACC_LP (D => 1); + SUBTYPE ACC_LP2 IS ACC_LP (D => 2); + + VAR1 : ACC_REC1 := NEW REC(1); + VAR2 : ACC_REC2 := NEW REC(2); + VAA1 : ACC_ARR1 := NEW ARR(1 .. 10); + VAA2 : ACC_ARR2 := NEW ARR(2 .. 5); + VAP1 : ACC_PV1 := NEW PV(1); + VAP2 : ACC_PV2 := NEW PV(2); + VAL1 : ACC_LP1 := NEW LP(1); + VAL2 : ACC_LP2 := NEW LP(2); + + FUNCTION FREC ( X : ACC_REC1) RETURN ACC_REC2 IS + BEGIN + RETURN X; + END FREC; + + FUNCTION FARR ( X : ACC_ARR1) RETURN ACC_ARR2 IS + BEGIN + RETURN X; + END FARR; + + FUNCTION FPV ( X : ACC_PV1) RETURN ACC_PV2 IS + BEGIN + RETURN X; + END FPV; + + FUNCTION FLP ( X : ACC_LP1) RETURN ACC_LP2 IS + BEGIN + RETURN X; + END FLP; + + PACKAGE BODY PACK IS + FUNCTION LF (X : LP) RETURN INTEGER IS + BEGIN + RETURN IDENT_INT(3); + END LF; + BEGIN + NULL; + END PACK; + +BEGIN + + TEST ("C58005H", "CHECK ACCESS CONSTRAINTS ON RETURN VALUES " & + "OF FUNCTIONS"); + + BEGIN + VAR2 := FREC (VAR1); + IF VAR2.D /= REPORT.IDENT_INT(2) THEN + FAILED ("CONSTRAINT_ERROR NOT RAISED - REC 1"); + ELSE + FAILED ("CONSTRAINT_ERROR NOT RAISED - REC 2"); + END IF; + EXCEPTION + WHEN CONSTRAINT_ERROR => NULL; + WHEN OTHERS => + FAILED ("WRONG EXCEPTION RAISED - REC"); + END; + + BEGIN + VAA2 := FARR (VAA1); + IF VAA2'FIRST /= REPORT.IDENT_INT(2) THEN + FAILED ("CONSTRAINT_ERROR NOT RAISED - ARR 1"); + ELSE + FAILED ("CONSTRAINT_ERROR NOT RAISED - ARR 2"); + END IF; + EXCEPTION + WHEN CONSTRAINT_ERROR => NULL; + WHEN OTHERS => + FAILED ("WRONG EXCEPTION RAISED - ARR"); + END; + + BEGIN + VAP2 := FPV (VAP1); + IF VAP2.D /= REPORT.IDENT_INT(2) THEN + FAILED ("CONSTRAINT_ERROR NOT RAISED - PV 1"); + ELSE + FAILED ("CONSTRAINT_ERROR NOT RAISED - PV 2"); + END IF; + EXCEPTION + WHEN CONSTRAINT_ERROR => NULL; + WHEN OTHERS => + FAILED ("WRONG EXCEPTION RAISED - PV"); + END; + + BEGIN + VAL2 := FLP (VAL1); + IF VAL2.D /= REPORT.IDENT_INT(2) THEN + FAILED ("CONSTRAINT_ERROR NOT RAISED - LP 1"); + ELSE + FAILED ("CONSTRAINT_ERROR NOT RAISED - LP 2"); + END IF; + EXCEPTION + WHEN CONSTRAINT_ERROR => NULL; + WHEN OTHERS => + FAILED ("WRONG EXCEPTION RAISED - LP"); + END; + + RESULT; +END C58005H; diff --git a/gcc/testsuite/ada/acats/tests/c5/c58006a.ada b/gcc/testsuite/ada/acats/tests/c5/c58006a.ada new file mode 100644 index 000000000..f7a2f1ca1 --- /dev/null +++ b/gcc/testsuite/ada/acats/tests/c5/c58006a.ada @@ -0,0 +1,128 @@ +-- C58006A.ADA + +-- Grant of Unlimited Rights +-- +-- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687, +-- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained +-- unlimited rights in the software and documentation contained herein. +-- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making +-- this public release, the Government intends to confer upon all +-- recipients unlimited rights equal to those held by the Government. +-- These rights include rights to use, duplicate, release or disclose the +-- released technical data and computer software in whole or in part, in +-- any manner and for any purpose whatsoever, and to have or permit others +-- to do so. +-- +-- DISCLAIMER +-- +-- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR +-- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED +-- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF 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 THE EVALUATION OF A RETURN STATEMENT'S EXPRESSION +-- RAISES AN EXCEPTION, THE EXCEPTION CAN BE HANDLED WITHIN THE BODY OF +-- THE FUNCTION. + +-- RM 05/11/81 +-- SPS 10/26/82 +-- SPS 3/8/83 +-- JBG 9/13/83 + +WITH REPORT; +PROCEDURE C58006A IS + + USE REPORT; + +BEGIN + + TEST( "C58006A" , "CHECK THAT EXCEPTION RAISED BY A RETURN" & + " STATEMENT CAN BE HANDLED LOCALLY" ); + + + DECLARE + SUBTYPE I1 IS INTEGER RANGE -10..90; + SUBTYPE I2 IS INTEGER RANGE 1..10; + + FUNCTION FN1( X : I1 ) + RETURN I2 IS + BEGIN + RETURN 0; + EXCEPTION + WHEN CONSTRAINT_ERROR => + COMMENT ("EXCEPTION RAISED - F1"); + RETURN 1; + WHEN OTHERS => + FAILED ("WRONG EXCEPTION RAISED - FN1"); + END FN1; + + FUNCTION FN2( X : I1 ) + RETURN I2 IS + BEGIN + RETURN X + IDENT_INT(0); + EXCEPTION + WHEN CONSTRAINT_ERROR => + COMMENT ("EXCEPTION RAISED - F2"); + RETURN 1; + WHEN OTHERS => + FAILED ("WRONG EXCEPTION RAISED - FN2"); + END FN2; + + FUNCTION FN3( X : I1 ) + RETURN I2 IS + HUNDRED : INTEGER RANGE -100..100 := IDENT_INT(100); + BEGIN + RETURN HUNDRED; + EXCEPTION + WHEN CONSTRAINT_ERROR => + COMMENT ("EXCEPTION RAISED - F3"); + RETURN 1; + WHEN OTHERS => + FAILED ("WRONG EXCEPTION RAISED - FN3"); + END FN3; + + BEGIN + + BEGIN + IF FN1( 0 ) /= IDENT_INT(1) THEN + FAILED ("NO EXCEPTION RAISED - FN1( 0 )"); + END IF; + EXCEPTION + WHEN OTHERS => + FAILED ("EXCEPTION PROPAGATED - FN1( 0 )"); + END; + + BEGIN + IF FN2( 0 ) /= IDENT_INT(1) THEN + FAILED ("NO EXCEPTION RAISED - FN2( 0 )"); + END IF; + EXCEPTION + WHEN OTHERS => + FAILED ("EXCEPTION PROPAGATED - FN2( 0 )"); + END; + + BEGIN + IF FN2(11 ) /= IDENT_INT(1) THEN + FAILED ("NO EXCEPTION RAISED - FN2(11 )"); + END IF; + EXCEPTION + WHEN OTHERS => + FAILED ("EXCEPTION PROPAGATED - FN2(11 )"); + END; + + BEGIN + IF FN3( 0 ) /= IDENT_INT(1) THEN + FAILED ("NO EXCEPTION RAISED - FN3( 0 )"); + END IF; + EXCEPTION + WHEN OTHERS => + FAILED ("EXCEPTION PROPAGATED - FN3( 0 )"); + END; + + END; + + RESULT; + +END C58006A; diff --git a/gcc/testsuite/ada/acats/tests/c5/c58006b.ada b/gcc/testsuite/ada/acats/tests/c5/c58006b.ada new file mode 100644 index 000000000..82b313255 --- /dev/null +++ b/gcc/testsuite/ada/acats/tests/c5/c58006b.ada @@ -0,0 +1,141 @@ +-- C58006B.ADA + +-- Grant of Unlimited Rights +-- +-- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687, +-- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained +-- unlimited rights in the software and documentation contained herein. +-- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making +-- this public release, the Government intends to confer upon all +-- recipients unlimited rights equal to those held by the Government. +-- These rights include rights to use, duplicate, release or disclose the +-- released technical data and computer software in whole or in part, in +-- any manner and for any purpose whatsoever, and to have or permit others +-- to do so. +-- +-- DISCLAIMER +-- +-- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR +-- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED +-- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF 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 THE EVALUATION OF A RETURN STATEMENT'S EXPRESSION +-- RAISES AN EXCEPTION, THE EXCEPTION CAN BE HANDLED WITHIN THE BODY OF +-- THE FUNCTION. + +-- CHECKS GENERIC FUNCTIONS. + +-- SPS 3/8/83 +-- JBG 9/13/83 + +WITH REPORT; +PROCEDURE C58006B IS + + USE REPORT; + +BEGIN + + TEST( "C58006B" , "CHECK THAT EXCEPTION RAISED BY A RETURN" & + " STATEMENT CAN BE HANDLED LOCALLY" ); + + + DECLARE + SUBTYPE I1 IS INTEGER RANGE -10..90; + SUBTYPE I2 IS INTEGER RANGE 1..10; + + GENERIC + FUNCTION FN1 (X : I1) RETURN I2; + + GENERIC + FUNCTION FN2 (X : I1) RETURN I2; + + GENERIC + FUNCTION FN3 (X : I1) RETURN I2; + + FUNCTION FN1( X : I1 ) + RETURN I2 IS + BEGIN + RETURN 0; + EXCEPTION + WHEN CONSTRAINT_ERROR => + COMMENT ("EXCEPTION RAISED - F1"); + RETURN 1; + WHEN OTHERS => + FAILED ("WRONG EXCEPTION RAISED - FN1"); + END FN1; + + FUNCTION FN2( X : I1 ) + RETURN I2 IS + BEGIN + RETURN X + IDENT_INT(0); + EXCEPTION + WHEN CONSTRAINT_ERROR => + COMMENT ("EXCEPTION RAISED - F2"); + RETURN 1; + WHEN OTHERS => + FAILED ("WRONG EXCEPTION RAISED - FN2"); + END FN2; + + FUNCTION FN3( X : I1 ) + RETURN I2 IS + HUNDRED : INTEGER RANGE -100..100 := IDENT_INT(100); + BEGIN + RETURN HUNDRED; + EXCEPTION + WHEN CONSTRAINT_ERROR => + COMMENT ("EXCEPTION RAISED - F3"); + RETURN 1; + WHEN OTHERS => + FAILED ("WRONG EXCEPTION RAISED - FN3"); + END FN3; + + FUNCTION F1 IS NEW FN1; + FUNCTION F2 IS NEW FN2; + FUNCTION F3 IS NEW FN3; + + BEGIN + + BEGIN + IF F1( 0 ) /= IDENT_INT(1) THEN + FAILED ("NO EXCEPTION RAISED - F1( 0 )"); + END IF; + EXCEPTION + WHEN OTHERS => + FAILED ("EXCEPTION PROPAGATED - F1( 0 )"); + END; + + BEGIN + IF F2( 0 ) /= IDENT_INT(1) THEN + FAILED ("NO EXCEPTION RAISED - F2( 0 )"); + END IF; + EXCEPTION + WHEN OTHERS => + FAILED ("EXCEPTION PROPAGATED - F2( 0 )"); + END; + + BEGIN + IF F2(11 ) /= IDENT_INT(1) THEN + FAILED ("NO EXCEPTION RAISED - F2(11 )"); + END IF; + EXCEPTION + WHEN OTHERS => + FAILED ("EXCEPTION PROPAGATED - F2(11 )"); + END; + + BEGIN + IF F3( 0 ) /= IDENT_INT(1) THEN + FAILED ("NO EXCEPTION RAISED - F3( 0 )"); + END IF; + EXCEPTION + WHEN OTHERS => + FAILED ("EXCEPTION PROPAGATED - F3( 0 )"); + END; + + END; + + RESULT; + +END C58006B; diff --git a/gcc/testsuite/ada/acats/tests/c5/c59002a.ada b/gcc/testsuite/ada/acats/tests/c5/c59002a.ada new file mode 100644 index 000000000..521071972 --- /dev/null +++ b/gcc/testsuite/ada/acats/tests/c5/c59002a.ada @@ -0,0 +1,102 @@ +-- C59002A.ADA + +-- Grant of Unlimited Rights +-- +-- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687, +-- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained +-- unlimited rights in the software and documentation contained herein. +-- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making +-- this public release, the Government intends to confer upon all +-- recipients unlimited rights equal to those held by the Government. +-- These rights include rights to use, duplicate, release or disclose the +-- released technical data and computer software in whole or in part, in +-- any manner and for any purpose whatsoever, and to have or permit others +-- to do so. +-- +-- DISCLAIMER +-- +-- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR +-- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED +-- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF 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 JUMPS OUT OF AN EXCEPTION HANDLER CONTAINED IN A BLOCK +-- TO A STATEMENT IN AN ENCLOSING UNIT ARE ALLOWED AND ARE PERFORMED +-- CORRECTLY. + + +-- RM 05/22/81 +-- SPS 3/8/83 + +WITH REPORT; +PROCEDURE C59002A IS + + USE REPORT ; + +BEGIN + + TEST( "C59002A" , "CHECK THAT JUMPS OUT OF EXCEPTION HANDLERS" & + " ARE ALLOWED" ); + + DECLARE + + FLOW : INTEGER := 1 ; + EXPON: INTEGER RANGE 0..3 := 0 ; + + BEGIN + + GOTO START ; + + FAILED( "'GOTO' NOT OBEYED" ); + + << BACK_LABEL >> + FLOW := FLOW * 3**EXPON ; -- 1*5*9 + EXPON := EXPON + 1 ; + GOTO FINISH ; + + << START >> + FLOW := FLOW * 7**EXPON ; -- 1 + EXPON := EXPON + 1 ; + + DECLARE + BEGIN + RAISE CONSTRAINT_ERROR ; + FAILED( "EXCEPTION NOT RAISED - 1" ); + EXCEPTION + WHEN CONSTRAINT_ERROR => + GOTO FORWARD_LABEL ; + END ; + + FAILED( "INNER 'GOTO' NOT OBEYED - 1" ); + + << FORWARD_LABEL >> + FLOW := FLOW * 5**EXPON ; -- 1*5 + EXPON := EXPON + 1 ; + + DECLARE + BEGIN + RAISE CONSTRAINT_ERROR ; + FAILED( "EXCEPTION NOT RAISED - 2" ); + EXCEPTION + WHEN CONSTRAINT_ERROR => + GOTO BACK_LABEL ; + END ; + + FAILED( "INNER 'GOTO' NOT OBETED - 2" ); + + << FINISH >> + FLOW := FLOW * 2**EXPON ; -- 1*5*9*8 + + IF FLOW /= 360 THEN + FAILED( "WRONG FLOW OF CONTROL" ); + END IF; + + END ; + + + RESULT ; + + +END C59002A; diff --git a/gcc/testsuite/ada/acats/tests/c5/c59002b.ada b/gcc/testsuite/ada/acats/tests/c5/c59002b.ada new file mode 100644 index 000000000..aee5839a7 --- /dev/null +++ b/gcc/testsuite/ada/acats/tests/c5/c59002b.ada @@ -0,0 +1,209 @@ +-- C59002B.ADA + +-- Grant of Unlimited Rights +-- +-- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687, +-- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained +-- unlimited rights in the software and documentation contained herein. +-- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making +-- this public release, the Government intends to confer upon all +-- recipients unlimited rights equal to those held by the Government. +-- These rights include rights to use, duplicate, release or disclose the +-- released technical data and computer software in whole or in part, in +-- any manner and for any purpose whatsoever, and to have or permit others +-- to do so. +-- +-- DISCLAIMER +-- +-- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR +-- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED +-- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF 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 JUMPS OUT OF COMPOUND STATEMENTS (OTHER THAN +-- ACCEPT STATEMENTS) ARE POSSIBLE AND ARE CORRECTLY PERFORMED. + + +-- FLOW OF CONTROL: A -> B -> C -> D -> E -> F -> G -> H . +-- | | | | | | | +-- IF LOOP CASE BLOCK IF LOOP CASE +-- LOOP CASE BLOCK + + +-- A : GOTO B L111 -> L311 +-- FAILURE L121 +-- E : GOTO F L131 -> L331 + +-- FAILURE L100 + +-- C : GOTO D L211 -> L411 +-- FAILURE L221 +-- G : GOTO H L231 + +-- FAILURE L200 + +-- B : GOTO C L311 -> L211 +-- FAILURE L321 +-- F : GOTO G L331 + +-- FAILURE L300 + +-- D : GOTO E L411 -> L131 +-- FAILURE L421 +-- H : L431 -> (OUT) + +-- PRINT RESULTS + + +-- RM 06/05/81 +-- SPS 3/8/83 + +WITH REPORT; +PROCEDURE C59002B IS + + USE REPORT ; + +BEGIN + + TEST( "C59002B" , "CHECK THAT ONE CAN JUMP OUT OF COMPOUND STATE" & + "MENTS" ); + + + DECLARE + + FLOW_STRING : STRING(1..8) := "XXXXXXXX" ; + INDEX : INTEGER := 1 ; + + BEGIN + + << L111 >> + + FLOW_STRING(INDEX) := 'A' ; + INDEX := INDEX + 1 ; + + IF FALSE THEN + FAILED( "WRONG 'IF' BRANCH" ); + ELSE + GOTO L311 ; + END IF; + + << L121 >> + + FAILED( "AT L121 - WRONGLY" ); + + << L131 >> + + FLOW_STRING(INDEX) := 'E' ; + INDEX := INDEX + 1 ; + + IF FALSE THEN + FAILED( "WRONG 'IF' BRANCH" ); + ELSE + FOR J IN 1..1 LOOP + GOTO L331 ; + END LOOP; + END IF; + + << L100 >> + + FAILED( "AT L100 - WRONGLY" ); + + << L211 >> + + FLOW_STRING(INDEX) := 'C' ; + INDEX := INDEX + 1 ; + + CASE 2 IS + WHEN 1 => + FAILED( "WRONG 'CASE' BRANCH" ); + WHEN OTHERS => + GOTO L411 ; + END CASE; + + << L221 >> + + FAILED( "AT L221 - WRONGLY" ); + + << L231 >> + + FLOW_STRING(INDEX) := 'G' ; + INDEX := INDEX + 1 ; + + CASE 2 IS + WHEN 1 => + FAILED( "WRONG 'CASE' BRANCH" ); + WHEN OTHERS => + DECLARE + BEGIN + GOTO L431 ; + END ; + END CASE; + + << L200 >> + + FAILED( "AT L200 - WRONGLY" ); + + << L311 >> + + FLOW_STRING(INDEX) := 'B' ; + INDEX := INDEX + 1 ; + + FOR I IN 1..1 LOOP + GOTO L211 ; + END LOOP; + + << L321 >> + + FAILED( "AT L321 - WRONGLY" ); + + << L331 >> + + FLOW_STRING(INDEX) := 'F' ; + INDEX := INDEX + 1 ; + + FOR I IN 1..1 LOOP + CASE 2 IS + WHEN 1 => + FAILED( "WRONG 'CASE' BRANCH" ); + WHEN OTHERS => + GOTO L231 ; + END CASE; + END LOOP; + + << L300 >> + + FAILED( "AT L300 - WRONGLY" ); + + << L411 >> + + FLOW_STRING(INDEX) := 'D' ; + INDEX := INDEX + 1 ; + + DECLARE + K : INTEGER := 17 ; + BEGIN + GOTO L131 ; + END; + + << L421 >> + + FAILED( "AT L421 - WRONGLY" ); + + << L431 >> + + FLOW_STRING(INDEX) := 'H' ; + + + IF FLOW_STRING /= "ABCDEFGH" THEN + FAILED("WRONG FLOW OF CONTROL" ); + END IF; + + END ; + + + RESULT ; + + +END C59002B; diff --git a/gcc/testsuite/ada/acats/tests/c5/c59002c.ada b/gcc/testsuite/ada/acats/tests/c5/c59002c.ada new file mode 100644 index 000000000..cc01a7e6c --- /dev/null +++ b/gcc/testsuite/ada/acats/tests/c5/c59002c.ada @@ -0,0 +1,150 @@ +-- C59002C.ADA + +-- Grant of Unlimited Rights +-- +-- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687, +-- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained +-- unlimited rights in the software and documentation contained herein. +-- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making +-- this public release, the Government intends to confer upon all +-- recipients unlimited rights equal to those held by the Government. +-- These rights include rights to use, duplicate, release or disclose the +-- released technical data and computer software in whole or in part, in +-- any manner and for any purpose whatsoever, and to have or permit others +-- to do so. +-- +-- DISCLAIMER +-- +-- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR +-- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED +-- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF 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 JUMPS OUT OF SELECT STATEMENTS (OTHER THAN +-- FROM INSIDE ACCEPT BODIES IN SELECT_ALTERNATIVES) +-- ARE POSSIBLE AND ARE CORRECTLY PERFORMED. + +-- THIS TEST CONTAINS SHARED VARIABLES. + + +-- RM 08/15/82 +-- SPS 12/13/82 +-- PWN 11/30/94 REMOVED PRAGMA PRIORITY INSTANCES FOR ADA 9X. + +with Impdef; +WITH REPORT; +WITH SYSTEM; +USE SYSTEM; +PROCEDURE C59002C IS + + USE REPORT ; + + FLOW_STRING : STRING(1..2) := "XX" ; + INDEX : INTEGER := 1 ; + + +BEGIN + + TEST( "C59002C" , "CHECK THAT ONE CAN JUMP OUT OF SELECT STATE" & + "MENTS" ); + + ------------------------------------------------------------------- + + DECLARE + + TASK T IS + + + ENTRY E1 ; + ENTRY E2 ; + END T ; + + TASK BODY T IS + BEGIN + + WHILE E2'COUNT <= 0 LOOP + DELAY 1.0 * Impdef.One_Second; + END LOOP; + + SELECT + ACCEPT E1 DO + FAILED( " E1 ACCEPTED; NO ENTRY CALL (1)" ); + END ; + OR + ACCEPT E2 ; + GOTO L123 ; + FAILED( "'GOTO' NOT OBEYED (1)" ); + OR + DELAY 10.0 * Impdef.One_Second; + FAILED( "DELAY ALTERNATIVE SELECTED (1)" ); + END SELECT; + + FAILED( "WRONG DESTINATION FOR 'GOTO' (1)" ); + + << L123 >> + + FLOW_STRING(INDEX) := 'A' ; + INDEX := INDEX + 1 ; + + END T; + + BEGIN + + T.E2 ; + + END; + + ------------------------------------------------------------------- + + DECLARE + + TASK T IS + ENTRY E1 ; + ENTRY E2 ; + END T ; + + TASK BODY T IS + BEGIN + + SELECT + ACCEPT E1 DO + FAILED( " E1 ACCEPTED; NO ENTRY CALL (2)" ); + END ; + OR + ACCEPT E2 DO + FAILED( " E2 ACCEPTED; NO ENTRY CALL (2)" ); + END ; + OR + DELAY 10.0 * Impdef.One_Second; + GOTO L321 ; + FAILED( "'GOTO' NOT OBEYED (2)" ); + END SELECT; + + FAILED( "WRONG DESTINATION FOR 'GOTO' (2)" ); + + << L321 >> + + FLOW_STRING(INDEX) := 'B' ; + INDEX := INDEX + 1 ; + + END T; + + BEGIN + + NULL ; + + END; + + ------------------------------------------------------------------- + + IF FLOW_STRING /= "AB" THEN + FAILED("WRONG FLOW OF CONTROL" ); + END IF; + + + RESULT ; + + +END C59002C ; |