diff options
Diffstat (limited to 'gcc-4.9/gcc/testsuite/ada/acats/tests/c3')
375 files changed, 72736 insertions, 0 deletions
diff --git a/gcc-4.9/gcc/testsuite/ada/acats/tests/c3/c32001a.ada b/gcc-4.9/gcc/testsuite/ada/acats/tests/c3/c32001a.ada new file mode 100644 index 000000000..5d90b62b0 --- /dev/null +++ b/gcc-4.9/gcc/testsuite/ada/acats/tests/c3/c32001a.ada @@ -0,0 +1,152 @@ +-- C32001A.ADA + +-- Grant of Unlimited Rights +-- +-- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687, +-- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained +-- unlimited rights in the software and documentation contained herein. +-- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making +-- this public release, the Government intends to confer upon all +-- recipients unlimited rights equal to those held by the Government. +-- These rights include rights to use, duplicate, release or disclose the +-- released technical data and computer software in whole or in part, in +-- any manner and for any purpose whatsoever, and to have or permit others +-- to do so. +-- +-- DISCLAIMER +-- +-- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR +-- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED +-- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF 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 IN MULTIPLE OBJECT DECLARATIONS FOR SCALAR TYPES, THE +-- SUBTYPE INDICATION AND THE INITIALIZATION EXPRESSIONS ARE EVALUATED +-- ONCE FOR EACH NAMED OBJECT THAT IS DECLARED AND THE SUBTYPE +-- INDICATION IS EVALUATED FIRST. ALSO, CHECK THAT THE EVALUATIONS +-- YIELD THE SAME RESULT AS A SEQUENCE OF SINGLE OBJECT DECLARATIONS. + +-- RJW 7/16/86 + +WITH REPORT; USE REPORT; + +PROCEDURE C32001A IS + + BUMP : ARRAY (1 .. 8) OF INTEGER := (OTHERS => 0); + + FUNCTION F (I : INTEGER) RETURN INTEGER IS + BEGIN + BUMP (I) := BUMP (I) + 1; + RETURN BUMP (I); + END F; + +BEGIN + TEST ("C32001A", "CHECK THAT IN MULTIPLE OBJECT DECLARATION " & + "FOR SCALAR TYPES, THE SUBTYPE INDICATION " & + "AND THE INITIALIZATION EXPRESSIONS ARE " & + "EVALUATED ONCE FOR EACH NAMED OBJECT THAT " & + "IS DECLARED AND THE SUBTYPE INDICATION IS " & + "EVALUATED FIRST. ALSO, CHECK THAT THE " & + "EVALUATIONS YIELD THE SAME RESULT AS A " & + "SEQUENCE OF SINGLE OBJECT DECLARATIONS" ); + + DECLARE + + TYPE DAY IS (MON, TUES, WED, THURS, FRI); + D1, D2 : DAY + RANGE MON .. DAY'VAL (F (1)) := + DAY'VAL (F (1) - 1); + CD1, CD2 : CONSTANT DAY + RANGE MON .. DAY'VAL (F (2)) := + DAY'VAL (F (2) - 1); + + I1, I2 : INTEGER RANGE 0 .. F (3) := + F (3) - 1; + CI1, CI2 : CONSTANT INTEGER RANGE 0 .. F (4) + := F (4) - 1; + + TYPE FLT IS DIGITS 3 RANGE -5.0 .. 5.0; + FL1, FL2 : FLT RANGE 0.0 .. FLT (F (5)) := + FLT (F (5) - 1); + CFL1, CFL2 : CONSTANT FLT + RANGE 0.0 .. FLT (F (6)) := + FLT (F (6) - 1); + + TYPE FIX IS DELTA 1.0 RANGE -5.0 .. 5.0; + FI1, FI2 : FIX RANGE 0.0 .. FIX (F (7)) := + FIX (F (7) - 1); + CFI1, CFI2 : CONSTANT FIX + RANGE 0.0 .. FIX (F (8)) := + FIX (F (8) - 1); + + BEGIN + IF D1 /= TUES THEN + FAILED ( "D1 NOT INITIALIZED TO CORRECT VALUE" ); + END IF; + + IF D2 /= THURS THEN + FAILED ( "D2 NOT INITIALIZED TO CORRECT VALUE" ); + END IF; + + IF CD1 /= TUES THEN + FAILED ( "CD1 NOT INITIALIZED TO CORRECT VALUE" ); + END IF; + + IF CD2 /= THURS THEN + FAILED ( "CD2 NOT INITIALIZED TO CORRECT VALUE" ); + END IF; + + IF I1 /= 1 THEN + FAILED ( "I1 NOT INITIALIZED TO CORRECT VALUE" ); + END IF; + + IF I2 /= 3 THEN + FAILED ( "I2 NOT INITIALIZED TO CORRECT VALUE" ); + END IF; + + IF CI1 /= 1 THEN + FAILED ( "CI1 NOT INITIALIZED TO CORRECT VALUE" ); + END IF; + + IF CI2 /= 3 THEN + FAILED ( "CI2 NOT INITIALIZED TO CORRECT VALUE" ); + END IF; + + IF FL1 /= 1.0 THEN + FAILED ( "FL1 NOT INITIALIZED TO CORRECT VALUE" ); + END IF; + + IF FL2 /= 3.0 THEN + FAILED ( "FL2 NOT INITIALIZED TO CORRECT VALUE" ); + END IF; + + IF CFL1 /= 1.0 THEN + FAILED ( "CFL1 NOT INITIALIZED TO CORRECT VALUE" ); + END IF; + + IF CFL2 /= 3.0 THEN + FAILED ( "CFL2 NOT INITIALIZED TO CORRECT VALUE" ); + END IF; + + IF FI1 /= 1.0 THEN + FAILED ( "FI1 NOT INITIALIZED TO CORRECT VALUE" ); + END IF; + + IF FI2 /= 3.0 THEN + FAILED ( "FI2 NOT INITIALIZED TO CORRECT VALUE" ); + END IF; + + IF CFI1 /= 1.0 THEN + FAILED ( "CFI1 NOT INITIALIZED TO CORRECT VALUE" ); + END IF; + + IF CFI2 /= 3.0 THEN + FAILED ( "CFI2 NOT INITIALIZED TO CORRECT VALUE" ); + END IF; + + END; + + RESULT; +END C32001A; diff --git a/gcc-4.9/gcc/testsuite/ada/acats/tests/c3/c32001b.ada b/gcc-4.9/gcc/testsuite/ada/acats/tests/c3/c32001b.ada new file mode 100644 index 000000000..c4d5acc32 --- /dev/null +++ b/gcc-4.9/gcc/testsuite/ada/acats/tests/c3/c32001b.ada @@ -0,0 +1,249 @@ +-- C32001B.ADA + +-- Grant of Unlimited Rights +-- +-- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687, +-- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained +-- unlimited rights in the software and documentation contained herein. +-- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making +-- this public release, the Government intends to confer upon all +-- recipients unlimited rights equal to those held by the Government. +-- These rights include rights to use, duplicate, release or disclose the +-- released technical data and computer software in whole or in part, in +-- any manner and for any purpose whatsoever, and to have or permit others +-- to do so. +-- +-- DISCLAIMER +-- +-- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR +-- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED +-- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF 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 MULTIPLE OBJECT DECLARATIONS FOR ARRAY TYPES, THE +-- SUBTYPE INDICATION AND THE INITIALIZATION EXPRESSIONS ARE +-- EVALUATED ONCE FOR EACH NAMED OBJECT THAT IS DECLARED AND THE +-- SUBTYPE INDICATION IS EVALUATED FIRST. ALSO, CHECK THAT THE +-- EVALUATIONS YIELD THE SAME RESULT AS A SEQUENCE OF SINGLE OBJECT +-- DECLARATIONS. + +-- HISTORY: +-- RJW 07/16/86 CREATED ORIGINAL TEST. +-- BCB 08/18/87 CHANGED HEADER TO STANDARD HEADER FORMAT. CHANGED +-- COMMENTS FOR S4 AND CS4 TO READ THAT THE BOUNDS ARE +-- 1 .. 6 AND THE COMPONENT TYPE ARR IS 1 .. 5. + +WITH REPORT; USE REPORT; + +PROCEDURE C32001B IS + + TYPE ARR IS ARRAY (NATURAL RANGE <>) OF INTEGER; + + BUMP : ARRAY (1 .. 4) OF INTEGER := (0, 0, 0, 0); + + FUNCTION F (I : INTEGER) RETURN INTEGER IS + BEGIN + BUMP (I) := BUMP (I) + 1; + RETURN BUMP (I); + END F; + +BEGIN + TEST ("C32001B", "CHECK THAT IN MULTIPLE OBJECT DECLARATIONS " & + "FOR ARRAY TYPES, THE SUBTYPE INDICATION " & + "AND THE INITIALIZATION EXPRESSIONS ARE " & + "EVALUATED ONCE FOR EACH NAMED OBJECT THAT " & + "IS DECLARED AND THE SUBTYPE INDICATION IS " & + "EVALUATED FIRST. ALSO, CHECK THAT THE " & + "EVALUATIONS YIELD THE SAME RESULT AS A " & + "SEQUENCE OF SINGLE OBJECT DECLARATIONS" ); + + DECLARE + + S1, S2 : ARR (1 .. F (1)) := (OTHERS => F (1)); + CS1, CS2 : CONSTANT ARR (1 .. F (2)) := (OTHERS => F (2)); + + PROCEDURE CHECK (A, B : ARR; STR1, STR2 : STRING) IS + BEGIN + IF A'LAST /= 1 THEN + FAILED ( "INCORRECT UPPER BOUND FOR " & STR1 ); + END IF; + + IF A (1) /= 2 THEN + FAILED ( "INCORRECT INITIAL VALUE FOR " & STR1 ); + END IF; + + IF B'LAST /= 3 THEN + FAILED ( "INCORRECT UPPER BOUND FOR " & STR2 ); + END IF; + + BEGIN + IF B (1 .. 3) = (4, 5, 6) THEN + COMMENT ( STR2 & " WAS INITIALIZED TO " & + "(4, 5, 6)" ); + ELSIF B (1 .. 3) = (5, 4, 6) THEN + COMMENT ( STR2 & " WAS INITIALIZED TO " & + "(5, 4, 6)" ); + ELSIF B (1 .. 3) = (4, 6, 5) THEN + COMMENT ( STR2 & " WAS INITIALIZED TO " & + "(4, 6, 5)" ); + ELSIF B (1 .. 3) = (6, 4, 5) THEN + COMMENT ( STR2 & " WAS INITIALIZED TO " & + "(6, 4, 5)" ); + ELSIF B (1 .. 3) = (6, 5, 4) THEN + COMMENT ( STR2 & " WAS INITIALIZED TO " & + "(6, 5, 4)" ); + ELSIF B (1 .. 3) = (5, 6, 4) THEN + COMMENT ( STR2 & " WAS INITIALIZED TO " & + "(5, 6, 4)" ); + ELSE + FAILED ( STR2 & " HAS INCORRECT INITIAL " & + "VALUE" ); + END IF; + EXCEPTION + WHEN CONSTRAINT_ERROR => + FAILED ( "CONSTRAINT_ERROR RAISED - " & + STR2 ); + WHEN OTHERS => + FAILED ( "EXCEPTION RAISED - " & + STR2 ); + END; + END; + + BEGIN + CHECK (S1, S2, "S1", "S2"); + CHECK (CS1, CS2, "CS1", "CS2"); + END; + + DECLARE + + S3, S4 : ARRAY (1 .. F (3)) OF ARR (1 .. F (3)) := + (OTHERS => (OTHERS => F (3))); + + CS3, CS4 : CONSTANT ARRAY (1.. F (4)) OF + ARR (1 .. F (4)) := + (OTHERS => (OTHERS => F (4))); + BEGIN + IF S3'LAST = 1 THEN + IF S3 (1)'LAST = 2 THEN + COMMENT ( "S3 HAS BOUNDS 1 .. 1 AND " & + "COMPONENT TYPE ARR (1 .. 2)" ); + IF S3 (1)(1 .. 2) = (3, 4) THEN + COMMENT ( "S3 HAS INITIAL VALUES " & + "3 AND 4 - 1" ); + ELSIF S3 (1)(1 .. 2) = (4, 3) THEN + COMMENT ( "S3 HAS INITIAL VALUES " & + "4 AND 3 - 1" ); + ELSE + FAILED ( "S3 HAS WRONG INITIAL VALUES - 1" ); + END IF; + ELSE + FAILED ( "S3 HAS WRONG COMPONENT TYPE - 1" ); + END IF; + ELSIF S3'LAST = 2 THEN + IF S3 (1)'LAST = 1 THEN + COMMENT ( "S3 HAS BOUNDS 1 .. 2 AND " & + "COMPONENT TYPE ARR (1 .. 1)" ); + IF S3 (1) (1) = 3 AND S3 (2) (1) = 4 THEN + COMMENT ( "S3 HAS INITIAL VALUES " & + "3 AND 4 - 2" ); + ELSIF S3 (1) (1) = 4 AND S3 (2) (1) = 3 THEN + COMMENT ( "S3 HAS INITIAL VALUES " & + "4 AND 3 - 2" ); + ELSE + FAILED ( "S3 HAS WRONG INITIAL VALUES - 2" ); + END IF; + ELSE + FAILED ( "S3 HAS WRONG COMPONENT TYPE - 2" ); + END IF; + ELSE + FAILED ( "S3 HAS INCORRECT BOUNDS" ); + END IF; + + IF S4'LAST = 5 THEN + IF S4 (1)'LAST = 6 THEN + COMMENT ( "S4 HAS BOUNDS 1 .. 5 AND " & + "COMPONENT TYPE ARR (1 .. 6)" ); + ELSE + FAILED ( "S4 HAS WRONG COMPONENT TYPE - 1" ); + END IF; + ELSIF S4'LAST = 6 THEN + IF S4 (1)'FIRST = 1 AND S4 (1)'LAST = 5 THEN + COMMENT ( "S4 HAS BOUNDS 1 .. 6 AND " & + "COMPONENT TYPE ARR (1 .. 5)" ); + ELSE + FAILED ( "S4 HAS WRONG COMPONENT TYPE - 2" ); + END IF; + ELSE + FAILED ( "S4 HAS INCORRECT BOUNDS" ); + END IF; + + IF BUMP (3) /= 36 THEN + FAILED ( "FUNCTION F NOT INVOKED CORRECT NUMBER OF " & + "TIMES TO INITIALIZE S4" ); + END IF; + + IF CS3'FIRST = 1 AND CS3'LAST = 1 THEN + IF CS3 (1)'FIRST = 1 AND CS3 (1)'LAST = 2 THEN + COMMENT ( "CS3 HAS BOUNDS 1 .. 1 AND " & + "COMPONENT TYPE ARR (1 .. 2)" ); + IF CS3 (1)(1 .. 2) = (3, 4) THEN + COMMENT ( "CS3 HAS INITIAL VALUES " & + "3 AND 4 - 1" ); + ELSIF CS3 (1)(1 .. 2) = (4, 3) THEN + COMMENT ( "CS3 HAS INITIAL VALUES " & + "4 AND 3 - 1" ); + ELSE + FAILED ( "CS3 HAS WRONG INITIAL VALUES - 1" ); + END IF; + ELSE + FAILED ( "CS3 HAS WRONG COMPONENT TYPE - 1" ); + END IF; + ELSIF CS3'FIRST = 1 AND CS3'LAST = 2 THEN + IF CS3 (1)'FIRST = 1 AND CS3 (1)'LAST = 1 THEN + COMMENT ( "CS3 HAS BOUNDS 1 .. 2 AND " & + "COMPONENT TYPE ARR (1 .. 1)" ); + IF CS3 (1) (1) = 3 AND CS3 (2) (1) = 4 THEN + COMMENT ( "CS3 HAS INITIAL VALUES " & + "3 AND 4 - 2" ); + ELSIF CS3 (1) (1) = 4 AND CS3 (2) (1) = 3 THEN + COMMENT ( "CS3 HAS INITIAL VALUES " & + "4 AND 3 - 2" ); + ELSE + FAILED ( "CS3 HAS WRONG INITIAL VALUES - 2" ); + END IF; + ELSE + FAILED ( "CS3 HAS WRONG COMPONENT TYPE - 2" ); + END IF; + ELSE + FAILED ( "CS3 HAS INCORRECT BOUNDS" ); + END IF; + + IF CS4'FIRST = 1 AND CS4'LAST = 5 THEN + IF CS4 (1)'FIRST = 1 AND CS4 (1)'LAST = 6 THEN + COMMENT ( "CS4 HAS BOUNDS 1 .. 5 AND " & + "COMPONENT TYPE ARR (1 .. 6)" ); + ELSE + FAILED ( "CS4 HAS WRONG COMPONENT TYPE - 1" ); + END IF; + ELSIF CS4'FIRST = 1 AND CS4'LAST = 6 THEN + IF CS4 (1)'FIRST = 1 AND CS4 (1)'LAST = 5 THEN + COMMENT ( "CS4 HAS BOUNDS 1 .. 6 AND " & + "COMPONENT TYPE ARR (1 .. 5)" ); + ELSE + FAILED ( "CS4 HAS WRONG COMPONENT TYPE - 2" ); + END IF; + ELSE + FAILED ( "CS4 HAS INCORRECT BOUNDS" ); + END IF; + + IF BUMP (4) /= 36 THEN + FAILED ( "FUNCTION F NOT INVOKED CORRECT NUMBER OF " & + "TIMES TO INITIALIZE CS4" ); + END IF; + END; + + RESULT; +END C32001B; diff --git a/gcc-4.9/gcc/testsuite/ada/acats/tests/c3/c32001c.ada b/gcc-4.9/gcc/testsuite/ada/acats/tests/c3/c32001c.ada new file mode 100644 index 000000000..bc70568a7 --- /dev/null +++ b/gcc-4.9/gcc/testsuite/ada/acats/tests/c3/c32001c.ada @@ -0,0 +1,125 @@ +-- C32001C.ADA + +-- Grant of Unlimited Rights +-- +-- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687, +-- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained +-- unlimited rights in the software and documentation contained herein. +-- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making +-- this public release, the Government intends to confer upon all +-- recipients unlimited rights equal to those held by the Government. +-- These rights include rights to use, duplicate, release or disclose the +-- released technical data and computer software in whole or in part, in +-- any manner and for any purpose whatsoever, and to have or permit others +-- to do so. +-- +-- DISCLAIMER +-- +-- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR +-- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED +-- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF 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 IN MULTIPLE OBJECT DECLARATIONS FOR RECORD TYPES, THE +-- SUBTYPE INDICATION AND THE INITIALIZATION EXPRESSIONS ARE EVALUATED +-- ONCE FOR EACH NAMED OBJECT THAT IS DECLARED AND THE SUBTYPE +-- INDICATION IS EVALUATED FIRST. ALSO, CHECK THAT THE EVALUATIONS +-- YIELD THE SAME RESULT AS A SEQUENCE OF SINGLE OBJECT DECLARATIONS. + +-- RJW 7/16/86 + +WITH REPORT; USE REPORT; + +PROCEDURE C32001C IS + + TYPE ARR IS ARRAY (1 .. 2) OF INTEGER; + F1, G1 : ARR; + BUMP : ARR := (0, 0); + + FUNCTION F (I : INTEGER) RETURN INTEGER IS + BEGIN + BUMP (I) := BUMP(I) + 1; + F1 (I) := BUMP (I); + RETURN BUMP (I); + END F; + + FUNCTION G (I : INTEGER) RETURN INTEGER IS + BEGIN + BUMP (I) := BUMP(I) + 1; + G1 (I) := BUMP (I); + RETURN BUMP (I); + END G; + + FUNCTION H (I : INTEGER) RETURN INTEGER IS + BEGIN + BUMP (I) := BUMP(I) + 1; + RETURN BUMP (I); + END H; + +BEGIN + TEST ("C32001C", "CHECK THAT IN MULTIPLE OBJECT DECLARATIONS " & + "FOR RECORD TYPES, THE SUBTYPE INDICATION " & + "AND THE INITIALIZATION EXPRESSIONS ARE " & + "EVALUATED ONCE FOR EACH NAMED OBJECT THAT " & + "IS DECLARED AND THE SUBTYPE INDICATION IS " & + "EVALUATED FIRST. ALSO, CHECK THAT THE " & + "EVALUATIONS YIELD THE SAME RESULT AS A " & + "SEQUENCE OF SINGLE OBJECT DECLARATIONS" ); + + DECLARE + + TYPE REC (D1, D2 : INTEGER) IS + RECORD + VALUE : INTEGER; + END RECORD; + + R1, R2 : REC (F (1), G (1)) := + (F1 (1), G1 (1), VALUE => H (1)); + CR1, CR2 : CONSTANT REC (F (2), G (2)) := + (F1 (2), G1 (2), VALUE => H (2)); + + PROCEDURE CHECK + (R : REC; V1, V2, VAL : INTEGER; S : STRING) IS + BEGIN + IF R.D1 = V1 THEN + IF R.D2 = V2 THEN + COMMENT ( S & ".D1 INITIALIZED TO " & + INTEGER'IMAGE (V1) & " AND " & + S & ".D2 INITIALIZED TO " & + INTEGER'IMAGE (V2)); + ELSE + FAILED ( S & + ".D2 INITIALIZED INCORRECTLY - 1" ); + END IF; + ELSIF R.D1 = V2 THEN + IF R.D2 =V1 THEN + COMMENT ( S & ".D1 INITIALIZED TO " & + INTEGER'IMAGE (V2) & " AND " & + S & ".D2 INITIALIZED TO " & + INTEGER'IMAGE (V1)); + ELSE + FAILED ( S & + ".D2 INITIALIZED INCORRECTLY - 2" ); + END IF; + ELSE + FAILED ( S & ".D1 INITIALIZED INCORRECTLY TO " & + INTEGER'IMAGE (R.D1) ); + END IF; + + IF R.VALUE /= VAL THEN + FAILED ( S & ".VALUE INITIALIZED INCORRECTLY" ); + END IF; + END CHECK; + + BEGIN + CHECK (R1, 1, 2, 3, "R1"); + CHECK (R2, 4, 5, 6, "R2"); + + CHECK (CR1, 1, 2, 3, "CR1"); + CHECK (CR2, 4, 5, 6, "CR2"); + END; + + RESULT; +END C32001C; diff --git a/gcc-4.9/gcc/testsuite/ada/acats/tests/c3/c32001d.ada b/gcc-4.9/gcc/testsuite/ada/acats/tests/c3/c32001d.ada new file mode 100644 index 000000000..e8a6a20e0 --- /dev/null +++ b/gcc-4.9/gcc/testsuite/ada/acats/tests/c3/c32001d.ada @@ -0,0 +1,99 @@ +-- C32001D.ADA + +-- Grant of Unlimited Rights +-- +-- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687, +-- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained +-- unlimited rights in the software and documentation contained herein. +-- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making +-- this public release, the Government intends to confer upon all +-- recipients unlimited rights equal to those held by the Government. +-- These rights include rights to use, duplicate, release or disclose the +-- released technical data and computer software in whole or in part, in +-- any manner and for any purpose whatsoever, and to have or permit others +-- to do so. +-- +-- DISCLAIMER +-- +-- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR +-- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED +-- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF 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 IN MULTIPLE OBJECT DECLARATIONS FOR ACCESS TYPES, THE +-- SUBTYPE INDICATION AND THE INITIALIZATION EXPRESSIONS ARE EVALUATED +-- ONCE FOR EACH NAMED OBJECT THAT IS DECLARED AND THE SUBTYPE +-- INDICATION IS EVALUATED FIRST. ALSO, CHECK THAT THE EVALUATIONS +-- YIELD THE SAME RESULT AS A SEQUENCE OF SINGLE OBJECT DECLARATIONS. + +-- RJW 7/16/86 + +WITH REPORT; USE REPORT; + +PROCEDURE C32001D IS + + TYPE ARR IS ARRAY (1 .. 2) OF INTEGER; + BUMP : ARR := (0, 0); + F1 : ARR; + + FUNCTION F (I : INTEGER) RETURN INTEGER IS + BEGIN + BUMP (I) := BUMP (I) + 1; + F1 (I) := BUMP (I); + RETURN BUMP (I); + END F; + + FUNCTION G (I : INTEGER) RETURN INTEGER IS + BEGIN + BUMP (I) := BUMP (I) + 1; + RETURN BUMP (I); + END G; + +BEGIN + TEST ("C32001D", "CHECK THAT IN MULTIPLE OBJECT DECLARATIONS " & + "FOR ACCESS TYPES, THE SUBTYPE INDICATION " & + "AND THE INITIALIZATION EXPRESSIONS ARE " & + "EVALUATED ONCE FOR EACH NAMED OBJECT THAT " & + "IS DECLARED AND THE SUBTYPE INDICATION IS " & + "EVALUATED FIRST. ALSO, CHECK THAT THE " & + "EVALUATIONS YIELD THE SAME RESULT AS A " & + "SEQUENCE OF SINGLE OBJECT DECLARATIONS" ); + + DECLARE + + TYPE CELL (SIZE : INTEGER) IS + RECORD + VALUE : INTEGER; + END RECORD; + + TYPE LINK IS ACCESS CELL; + + L1, L2 : LINK (F (1)) := NEW CELL'(F1 (1), G (1)); + + CL1, CL2 : CONSTANT LINK (F (2)) := NEW CELL'(F1 (2), G (2)); + + PROCEDURE CHECK (L : LINK; V1, V2 : INTEGER; S : STRING) IS + BEGIN + IF L.SIZE /= V1 THEN + FAILED ( S & ".SIZE INITIALIZED INCORRECTLY TO " & + INTEGER'IMAGE (L.SIZE)); + END IF; + + IF L.VALUE /= V2 THEN + FAILED ( S & ".VALUE INITIALIZED INCORRECTLY TO " & + INTEGER'IMAGE (L.VALUE)); + END IF; + END CHECK; + + BEGIN + CHECK (L1, 1, 2, "L1"); + CHECK (L2, 3, 4, "L2"); + + CHECK (CL1, 1, 2, "CL1"); + CHECK (CL2, 3, 4, "CL2"); + END; + + RESULT; +END C32001D; diff --git a/gcc-4.9/gcc/testsuite/ada/acats/tests/c3/c32001e.ada b/gcc-4.9/gcc/testsuite/ada/acats/tests/c3/c32001e.ada new file mode 100644 index 000000000..253acc51f --- /dev/null +++ b/gcc-4.9/gcc/testsuite/ada/acats/tests/c3/c32001e.ada @@ -0,0 +1,253 @@ +-- C32001E.ADA + +-- Grant of Unlimited Rights +-- +-- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687, +-- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained +-- unlimited rights in the software and documentation contained herein. +-- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making +-- this public release, the Government intends to confer upon all +-- recipients unlimited rights equal to those held by the Government. +-- These rights include rights to use, duplicate, release or disclose the +-- released technical data and computer software in whole or in part, in +-- any manner and for any purpose whatsoever, and to have or permit others +-- to do so. +-- +-- DISCLAIMER +-- +-- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR +-- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED +-- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF 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 IN MULTIPLE OBJECT DECLARATIONS FOR PRIVATE TYPES, THE +-- SUBTYPE INDICATION AND THE INITIALIZATION EXPRESSIONS ARE EVALUATED +-- ONCE FOR EACH NAMED OBJECT THAT IS DECLARED AND THE SUBTYPE +-- INDICATION IS EVALUATED FIRST. ALSO, CHECK THAT THE EVALUATIONS +-- YIELD THE SAME RESULT AS A SEQUENCE OF SINGLE OBJECT DECLARATIONS. + +-- RJW 7/18/86 + +WITH REPORT; USE REPORT; + +PROCEDURE C32001E IS + + BUMP : ARRAY (1 .. 10) OF INTEGER := (OTHERS => 0); + G1 : ARRAY (5 .. 6) OF INTEGER; + + FUNCTION F (I : INTEGER) RETURN INTEGER IS + BEGIN + BUMP (I) := BUMP (I) + 1; + RETURN BUMP (I); + END F; + + FUNCTION G (I : INTEGER) RETURN INTEGER IS + BEGIN + BUMP (I) := BUMP (I) + 1; + G1 (I) := BUMP (I); + RETURN BUMP (I); + END G; + +BEGIN + TEST ("C32001E", "CHECK THAT IN MULTIPLE OBJECT DECLARATIONS " & + "FOR PRIVATE TYPES, THE SUBTYPE INDICATION " & + "AND THE INITIALIZATION EXPRESSIONS ARE " & + "EVALUATED ONCE FOR EACH NAMED OBJECT THAT " & + "IS DECLARED AND THE SUBTYPE INDICATION IS " & + "EVALUATED FIRST. ALSO, CHECK THAT THE " & + "EVALUATIONS YIELD THE SAME RESULT AS A " & + "SEQUENCE OF SINGLE OBJECT DECLARATIONS" ); + + DECLARE + PACKAGE PKG1 IS + TYPE PBOOL IS PRIVATE; + TYPE PINT IS PRIVATE; + TYPE PREC (D : INTEGER) IS PRIVATE; + TYPE PARR IS PRIVATE; + TYPE PACC IS PRIVATE; + + FUNCTION INIT1 (I : INTEGER) RETURN PBOOL; + FUNCTION INIT2 (I : INTEGER) RETURN PINT; + FUNCTION INIT3 (I : INTEGER) RETURN PREC; + FUNCTION INIT4 (I : INTEGER) RETURN PARR; + FUNCTION INIT5 (I : INTEGER) RETURN PACC; + + PROCEDURE CHECK1 (B : PBOOL; I : INTEGER; S : STRING); + PROCEDURE CHECK2 (I : PINT; J : INTEGER; S : STRING); + PROCEDURE CHECK3 (R : PREC; I, J : INTEGER; + S : STRING); + PROCEDURE CHECK4 (A : PARR; I, J : INTEGER; + S : STRING); + PROCEDURE CHECK5 (V : PACC; S : STRING); + PROCEDURE CHECK6 (V : PACC; S : STRING); + + PRIVATE + TYPE PBOOL IS NEW BOOLEAN; + TYPE PINT IS NEW INTEGER; + + TYPE PREC (D : INTEGER) IS + RECORD + VALUE : INTEGER; + END RECORD; + + TYPE PARR IS ARRAY (1 .. 2) OF INTEGER; + + TYPE VECTOR IS ARRAY (NATURAL RANGE <>) OF INTEGER; + TYPE PACC IS ACCESS VECTOR; + END PKG1; + + PACKAGE BODY PKG1 IS + FUNCTION INIT1 (I : INTEGER) RETURN PBOOL IS + BEGIN + RETURN PBOOL'VAL (F (I) - 1); + END INIT1; + + FUNCTION INIT2 (I : INTEGER) RETURN PINT IS + BEGIN + RETURN PINT'VAL (F (I)); + END INIT2; + + FUNCTION INIT3 (I : INTEGER) RETURN PREC IS + PR : PREC (G1 (I)) := (G1 (I), F (I)); + BEGIN + RETURN PR; + END INIT3; + + FUNCTION INIT4 (I : INTEGER) RETURN PARR IS + PA : PARR := (1 .. 2 => F (I)); + BEGIN + RETURN PA; + END INIT4; + + FUNCTION INIT5 (I : INTEGER) RETURN PACC IS + ACCV : PACC := NEW VECTOR'(1 .. F (I) => F (I)); + BEGIN + RETURN ACCV; + END INIT5; + + PROCEDURE CHECK1 (B : PBOOL; I : INTEGER; S : STRING) IS + BEGIN + IF B /= PBOOL'VAL (I) THEN + FAILED ( S & " HAS AN INCORRECT VALUE OF " & + PBOOL'IMAGE (B)); + END IF; + END CHECK1; + + PROCEDURE CHECK2 (I : PINT; J : INTEGER; S : STRING) IS + BEGIN + IF I /= PINT'VAL (J) THEN + FAILED ( S & " HAS AN INCORRECT VALUE OF " & + PINT'IMAGE (I)); + END IF; + END CHECK2; + + PROCEDURE CHECK3 (R : PREC; I, J : INTEGER; + S : STRING) IS + BEGIN + IF R.D /= I THEN + FAILED ( S & ".D HAS AN INCORRECT VALUE OF " + & INTEGER'IMAGE (R.D)); + END IF; + + IF R.VALUE /= J THEN + FAILED ( S & ".VALUE HAS AN INCORRECT " & + "VALUE OF " & + INTEGER'IMAGE (R.VALUE)); + END IF; + END CHECK3; + + PROCEDURE CHECK4 (A : PARR; I, J : INTEGER; + S : STRING) IS + BEGIN + IF A /= (I, J) AND A /= (J, I) THEN + FAILED ( S & " HAS AN INCORRECT VALUE" ); + END IF; + END CHECK4; + + PROCEDURE CHECK5 (V : PACC; S : STRING) IS + BEGIN + IF V'LAST /= 1 THEN + FAILED ( S & " HAS AN INCORRECT UPPER BOUND " + & "OF " & INTEGER'IMAGE (V'LAST)); + END IF; + + IF V (1) /= 2 THEN + FAILED ( S & " HAS AN INCORRECT COMPONENT " & + "VALUE" ); + END IF; + END CHECK5; + + PROCEDURE CHECK6 (V : PACC; S : STRING) IS + BEGIN + IF V'LAST /= 3 THEN + FAILED ( S & " HAS AN INCORRECT UPPER BOUND " + & "OF " & INTEGER'IMAGE (V'LAST)); + END IF; + + IF V.ALL = (4, 5, 6) OR V.ALL = (5, 4, 6) OR + V.ALL = (4, 6, 5) OR V.ALL = (6, 4, 5) OR + V.ALL = (5, 6, 4) OR V.ALL = (6, 5, 4) THEN + NULL; + ELSE + FAILED ( S & " HAS AN INCORRECT COMPONENT " & + "VALUE" ); + END IF; + END CHECK6; + + END PKG1; + + PACKAGE PKG2 IS END PKG2; + + PACKAGE BODY PKG2 IS + USE PKG1; + + B1, B2 : PBOOL := INIT1 (1); + CB1, CB2 : CONSTANT PBOOL := INIT1 (2); + + I1, I2 : PINT := INIT2 (3); + CI1, CI2 : CONSTANT PINT := INIT2 (4); + + R1, R2 : PREC (G (5)) := INIT3 (5); + CR1, CR2 : CONSTANT PREC (G (6)) := INIT3 (6); + + A1, A2 : PARR := INIT4 (7); + CA1, CA2 : CONSTANT PARR := INIT4 (8); + + V1, V2 : PACC := INIT5 (9); + CV1, CV2 : CONSTANT PACC := INIT5 (10); + + BEGIN + CHECK1 (B1, 0, "B1"); + CHECK1 (B2, 1, "B2"); + CHECK1 (CB1, 0, "CB1"); + CHECK1 (CB2, 1, "CB2"); + + CHECK2 (I1, 1, "I1"); + CHECK2 (I2, 2, "I2"); + CHECK2 (CI1, 1, "CI1"); + CHECK2 (CI2, 2, "CI2"); + + CHECK3 (R1, 1, 2, "R1"); + CHECK3 (R2, 3, 4, "R2"); + CHECK3 (CR1, 1, 2, "CR1"); + CHECK3 (CR2, 3, 4, "CR2"); + + CHECK4 (A1, 1, 2, "A1"); + CHECK4 (A2, 3, 4, "A2"); + CHECK4 (CA1, 1, 2, "CA1"); + CHECK4 (CA2, 3, 4, "CA2"); + + CHECK5 (V1, "V1"); + CHECK6 (V2, "V2"); + CHECK5 (CV1, "CV1"); + CHECK6 (CV2, "CV2"); + END PKG2; + + BEGIN + NULL; + END; + + RESULT; +END C32001E; diff --git a/gcc-4.9/gcc/testsuite/ada/acats/tests/c3/c32107a.ada b/gcc-4.9/gcc/testsuite/ada/acats/tests/c3/c32107a.ada new file mode 100644 index 000000000..fd4ed0926 --- /dev/null +++ b/gcc-4.9/gcc/testsuite/ada/acats/tests/c3/c32107a.ada @@ -0,0 +1,363 @@ +-- C32107A.ADA + +-- Grant of Unlimited Rights +-- +-- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687, +-- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained +-- unlimited rights in the software and documentation contained herein. +-- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making +-- this public release, the Government intends to confer upon all +-- recipients unlimited rights equal to those held by the Government. +-- These rights include rights to use, duplicate, release or disclose the +-- released technical data and computer software in whole or in part, in +-- any manner and for any purpose whatsoever, and to have or permit others +-- to do so. +-- +-- DISCLAIMER +-- +-- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR +-- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED +-- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF 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 OBJECT DECLARATIONS ARE ELABORATED IN THE ORDER OF THEIR +-- OCCURRENCE, I.E., THAT EXPRESSIONS ASSOCIATED WITH ONE DECLARATION +-- (INCLUDING DEFAULT EXPRESSIONS, IF APPROPRIATE) ARE EVALUATED BEFORE +-- ANY EXPRESSION BELONGING TO THE NEXT DECLARATION. ALSO, CHECK THAT +-- EXPRESSIONS IN THE SUBTYPE INDICATION OR THE CONSTRAINED ARRAY +-- DEFINITION ARE EVALUATED BEFORE ANY INITIALIZATION EXPRESSIONS ARE +-- EVALUATED. + +-- R.WILLIAMS 9/24/86 + +WITH REPORT; USE REPORT; +PROCEDURE C32107A IS + + BUMP : INTEGER := 0; + + ORDER_CHECK : INTEGER; + + G1, H1, I1 : INTEGER; + + FIRST_CALL : BOOLEAN := TRUE; + + TYPE ARR1 IS ARRAY (POSITIVE RANGE <>) OF INTEGER; + + TYPE ARR1_NAME IS ACCESS ARR1; + + TYPE ARR2 IS ARRAY (POSITIVE RANGE <>, POSITIVE RANGE <>) OF + INTEGER; + + TYPE REC (D : INTEGER) IS + RECORD + COMP : INTEGER; + END RECORD; + + TYPE REC_NAME IS ACCESS REC; + + FUNCTION F RETURN INTEGER IS + BEGIN + BUMP := BUMP + 1; + RETURN BUMP; + END F; + + FUNCTION G RETURN INTEGER IS + BEGIN + BUMP := BUMP + 1; + G1 := BUMP; + RETURN BUMP; + END G; + + FUNCTION H RETURN INTEGER IS + BEGIN + BUMP := BUMP + 1; + H1 := BUMP; + RETURN BUMP; + END H; + + FUNCTION I RETURN INTEGER IS + BEGIN + IF FIRST_CALL THEN + BUMP := BUMP + 1; + I1 := BUMP; + FIRST_CALL := FALSE; + END IF; + RETURN I1; + END I; + +BEGIN + TEST ( "C32107A", "CHECK THAT OBJECT DECLARATIONS ARE " & + "ELABORATED IN THE ORDER OF THEIR " & + "OCCURRENCE, I.E., THAT EXPRESSIONS " & + "ASSOCIATED WITH ONE DECLARATION (INCLUDING " & + "DEFAULT EXPRESSIONS, IF APPROPRIATE) ARE " & + "EVALUATED BEFORE ANY EXPRESSION BELONGING " & + "TO THE NEXT DECLARATION. ALSO, CHECK THAT " & + "EXPRESSIONS IN THE SUBTYPE INDICATION OR " & + "THE CONSTRAINED ARRAY DEFINITION ARE " & + "EVALUATED BEFORE ANY INITIALIZATION " & + "EXPRESSIONS ARE EVALUATED" ); + + DECLARE -- (A). + I1 : INTEGER := 10000 * F; + A1 : CONSTANT ARRAY (1 .. H) OF REC (G * 100) := + (1 .. H1 => (G1 * 100, I * 10)); + I2 : CONSTANT INTEGER := F * 1000; + BEGIN + ORDER_CHECK := I1 + I2 + A1'LAST + A1 (1).D + A1 (1).COMP; + IF ORDER_CHECK = 15243 OR ORDER_CHECK = 15342 THEN + COMMENT ( "ORDER_CHECK HAS VALUE " & + INTEGER'IMAGE (ORDER_CHECK) & " - (A)" ); + ELSE + FAILED ( "OBJECTS NOT ELABORATED IN PROPER ORDER " & + "VALUE OF ORDER_CHECK SHOULD BE 15343 OR " & + "15242 -- ACTUAL VALUE IS " & + INTEGER'IMAGE (ORDER_CHECK) & " - (A)" ); + END IF; + END; -- (A). + + BUMP := 0; + + DECLARE -- (B). + A : ARR2 (1 .. F, 1 .. F * 10); + R : REC (G * 100) := (G1 * 100, F * 1000); + I : INTEGER RANGE 1 .. H; + S : REC (F * 10); + BEGIN + ORDER_CHECK := + A'LAST (1) + A'LAST (2) + R.D + R.COMP; + IF (H1 + S.D = 65) AND + (ORDER_CHECK = 4321 OR ORDER_CHECK = 4312) THEN + COMMENT ( "ORDER_CHECK HAS VALUE 65 " & + INTEGER'IMAGE (ORDER_CHECK) & " - (B)" ); + ELSE + FAILED ( "OBJECTS NOT ELABORATED IN PROPER ORDER " & + "VALUE OF ORDER_CHECK SHOULD BE 65 4321 OR " & + "65 4312 -- ACTUAL VALUE IS " & + INTEGER'IMAGE (H1 + S.D) & + INTEGER'IMAGE (ORDER_CHECK) & " - (B)" ); + END IF; + END; -- (B). + + BUMP := 0; + + DECLARE -- (C). + I1 : CONSTANT INTEGER RANGE 1 .. G * 10 := F; + A1 : ARRAY (1 .. F * 100) OF INTEGER RANGE 1 .. H * 1000; + BEGIN + ORDER_CHECK := I1 + (G1 * 10) + A1'LAST + (H1 * 1000); + IF ORDER_CHECK = 4312 OR ORDER_CHECK = 3412 THEN + COMMENT ( "ORDER_CHECK HAS VALUE " & + INTEGER'IMAGE (ORDER_CHECK) & " - (C)" ); + ELSE + FAILED ( "OBJECTS NOT ELABORATED IN PROPER ORDER " & + "VALUE OF ORDER_CHECK SHOULD BE 4312 OR " & + "3412 -- ACTUAL VALUE IS " & + INTEGER'IMAGE (ORDER_CHECK) & " - (C)" ); + END IF; + END; -- (C). + + BUMP := 0; + FIRST_CALL := TRUE; + + DECLARE -- (D). + A1 : ARRAY (1 .. G) OF REC (H * 10000) := + (1 .. G1 => (H1 * 10000, I * 100)); + R1 : CONSTANT REC := (F * 1000, F * 10); + + BEGIN + ORDER_CHECK := + A1'LAST + A1 (1).D + A1 (1).COMP + R1.D + R1.COMP; + IF ORDER_CHECK = 25341 OR ORDER_CHECK = 24351 OR + ORDER_CHECK = 15342 OR ORDER_CHECK = 14352 THEN + COMMENT ( "ORDER_CHECK HAS VALUE " & + INTEGER'IMAGE (ORDER_CHECK) & " - (D)" ); + ELSE + FAILED ( "OBJECTS NOT ELABORATED IN PROPER ORDER " & + "VALUE OF ORDER_CHECK SHOULD BE 25341, " & + "24351, 15342 OR 14352 -- ACTUAL VALUE IS " & + INTEGER'IMAGE (ORDER_CHECK) & " - (D)" ); + END IF; + END; -- (D). + + BUMP := 0; + + DECLARE -- (E). + A1 : CONSTANT ARR1_NAME := NEW ARR1' (1 .. F => F * 10); + R1 : REC_NAME (H * 100) := NEW REC'(H1 * 100, F * 1000); + + BEGIN + ORDER_CHECK := A1.ALL'LAST + A1.ALL (1) + R1.D + R1.COMP; + IF ORDER_CHECK /= 4321 THEN + FAILED ( "OBJECTS NOT ELABORATED IN PROPER ORDER " & + "VALUE OF ORDER_CHECK SHOULD BE 4321 " & + "-- ACTUAL VALUE IS " & + INTEGER'IMAGE (ORDER_CHECK) & " - (E)" ); + END IF; + END; -- (E). + + BUMP := 0; + FIRST_CALL := TRUE; + + DECLARE -- (F). + A1 : CONSTANT ARRAY (1 .. G) OF INTEGER RANGE 1 .. H * 100 := + (1 .. G1 => I * 10); + A2 : ARR1 (1 .. F * 1000); + BEGIN + ORDER_CHECK := + A1'LAST + (H1 * 100) + A1 (1) + A2'LAST; + IF ORDER_CHECK = 4231 OR ORDER_CHECK = 4132 THEN + COMMENT ( "ORDER_CHECK HAS VALUE " & + INTEGER'IMAGE (ORDER_CHECK) & " - (F)" ); + ELSE + FAILED ( "OBJECTS NOT ELABORATED IN PROPER ORDER " & + "VALUE OF ORDER_CHECK SHOULD BE 4231 OR " & + "4132 -- ACTUAL VALUE IS " & + INTEGER'IMAGE (ORDER_CHECK) & " - (F)" ); + END IF; + END; -- (F). + + BUMP := 0; + + DECLARE -- (G). + A1 : ARR1_NAME (1 .. G) := NEW ARR1 (1 .. G1); + R1 : CONSTANT REC_NAME (H * 10) := + NEW REC'(H1 * 10, F * 100); + BEGIN + ORDER_CHECK := A1.ALL'LAST + R1.D + R1.COMP; + IF ORDER_CHECK /= 321 THEN + FAILED ( "OBJECTS NOT ELABORATED IN PROPER ORDER " & + "VALUE OF ORDER_CHECK SHOULD BE 321 OR " & + "-- ACTUAL VALUE IS " & + INTEGER'IMAGE (ORDER_CHECK) & " - (G)" ); + END IF; + END; -- (G). + + BUMP := 0; + + DECLARE -- (H). + TYPE REC (D : INTEGER := F) IS + RECORD + COMP : INTEGER := F * 10; + END RECORD; + + R1 : REC; + R2 : REC (G * 100) := (G1 * 100, F * 1000); + BEGIN + ORDER_CHECK := R1.D + R1.COMP + R2.D + R2.COMP; + IF ORDER_CHECK = 4321 OR ORDER_CHECK = 4312 OR + ORDER_CHECK = 3421 OR ORDER_CHECK = 3412 THEN + COMMENT ( "ORDER_CHECK HAS VALUE " & + INTEGER'IMAGE (ORDER_CHECK) & " - (H)" ); + ELSE + FAILED ( "OBJECTS NOT ELABORATED IN PROPER ORDER " & + "VALUE OF ORDER_CHECK SHOULD BE 4321, " & + "4312, 3421, OR 3412 -- ACTUAL VALUE IS " & + INTEGER'IMAGE (ORDER_CHECK) & " - (H)" ); + END IF; + END; -- (H). + + BUMP := 0; + + DECLARE -- (I). + TYPE REC2 (D1, D2 : INTEGER) IS + RECORD + COMP : INTEGER; + END RECORD; + + R1 : REC2 (G * 1000, H * 10000) := + (G1 * 1000, H1 * 10000, F * 100); + R2 : REC2 (F, F * 10); + BEGIN + ORDER_CHECK := R1.D1 + R1.D2 + R1.COMP + R2.D1 + R2.D2; + IF ORDER_CHECK = 21354 OR ORDER_CHECK = 21345 OR + ORDER_CHECK = 12345 OR ORDER_CHECK = 12354 THEN + COMMENT ( "ORDER_CHECK HAS VALUE " & + INTEGER'IMAGE (ORDER_CHECK) & " - (I)" ); + ELSE + FAILED ( "OBJECTS NOT ELABORATED IN PROPER ORDER " & + "VALUE OF ORDER_CHECK SHOULD BE 21354, " & + "21345, 12354, OR 12345 -- ACTUAL VALUE IS " & + INTEGER'IMAGE (ORDER_CHECK) & " - (I)" ); + END IF; + + END; -- (I). + + BUMP := 0; + + DECLARE -- (J). + PACKAGE P IS + TYPE PRIV (D : INTEGER) IS PRIVATE; + + P1 : CONSTANT PRIV; + P2 : CONSTANT PRIV; + + FUNCTION GET_A (P : PRIV) RETURN INTEGER; + PRIVATE + TYPE PRIV (D : INTEGER) IS + RECORD + COMP : INTEGER; + END RECORD; + P1 : CONSTANT PRIV := (F , F * 10); + P2 : CONSTANT PRIV := (F * 100, F * 1000); + END P; + + PACKAGE BODY P IS + FUNCTION GET_A (P : PRIV) RETURN INTEGER IS + BEGIN + RETURN P.COMP; + END GET_A; + END P; + + USE P; + BEGIN + ORDER_CHECK := P1.D + GET_A (P1) + P2.D + GET_A (P2); + IF ORDER_CHECK = 4321 OR ORDER_CHECK = 4312 OR + ORDER_CHECK = 3412 OR ORDER_CHECK = 3421 THEN + COMMENT ( "ORDER_CHECK HAS VALUE " & + INTEGER'IMAGE (ORDER_CHECK) & " - (J)" ); + ELSE + FAILED ( "OBJECTS NOT ELABORATED IN PROPER ORDER " & + "VALUE OF ORDER_CHECK SHOULD BE 4321, " & + "4312, 3421, OR 3412 -- ACTUAL VALUE IS " & + INTEGER'IMAGE (ORDER_CHECK) & " - (J)" ); + END IF; + END; -- (J). + + BUMP := 0; + + DECLARE -- (K). + PACKAGE P IS + TYPE PRIV (D1, D2 : INTEGER) IS PRIVATE; + + PRIVATE + TYPE PRIV (D1, D2 : INTEGER) IS + RECORD + NULL; + END RECORD; + END P; + + USE P; + + P1 : PRIV (F, F * 10); + P2 : PRIV (F * 100, F * 1000); + + BEGIN + ORDER_CHECK := P1.D1 + P1.D2 + P2.D1 + P2.D2; + IF ORDER_CHECK = 4321 OR ORDER_CHECK = 4312 OR + ORDER_CHECK = 3412 OR ORDER_CHECK = 3421 THEN + COMMENT ( "ORDER_CHECK HAS VALUE " & + INTEGER'IMAGE (ORDER_CHECK) & " - (K)" ); + ELSE + FAILED ( "OBJECTS NOT ELABORATED IN PROPER ORDER " & + "VALUE OF ORDER_CHECK SHOULD BE 4321, 4312, " & + "3421, OR 3412 -- ACTUAL VALUE IS " & + INTEGER'IMAGE (ORDER_CHECK) & " - (K)" ); + END IF; + + END; -- (K). + + RESULT; +END C32107A; diff --git a/gcc-4.9/gcc/testsuite/ada/acats/tests/c3/c32107c.ada b/gcc-4.9/gcc/testsuite/ada/acats/tests/c3/c32107c.ada new file mode 100644 index 000000000..31295356b --- /dev/null +++ b/gcc-4.9/gcc/testsuite/ada/acats/tests/c3/c32107c.ada @@ -0,0 +1,164 @@ +-- C32107C.ADA + +-- Grant of Unlimited Rights +-- +-- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687, +-- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained +-- unlimited rights in the software and documentation contained herein. +-- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making +-- this public release, the Government intends to confer upon all +-- recipients unlimited rights equal to those held by the Government. +-- These rights include rights to use, duplicate, release or disclose the +-- released technical data and computer software in whole or in part, in +-- any manner and for any purpose whatsoever, and to have or permit others +-- to do so. +-- +-- DISCLAIMER +-- +-- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR +-- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED +-- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE +-- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE +-- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A +-- PARTICULAR PURPOSE OF SAID MATERIAL. +--* +-- FOR OBJECTS OF A GENERIC FORMAL TYPE WHOSE ACTUAL PARAMETER IS A +-- TYPE WITH DEFAULT VALUES, CHECK THAT OBJECT DECLARATIONS ARE +-- ELABORATED IN THE ORDER OF THEIR OCCURRENCE, I.E., THAT EXPRESSIONS +-- ASSOCIATED WITH ONE DECLARATION (INCLUDING DEFAULT EXPRESSIONS) ARE +-- EVALUATED BEFORE ANY EXPRESSION BELONGING TO THE NEXT DECLARATION. + +-- R.WILLIAMS 9/24/86 + +WITH REPORT; USE REPORT; +PROCEDURE C32107C IS + + BUMP : INTEGER := 0; + + G1, H1 : INTEGER; + + FUNCTION F RETURN INTEGER IS + BEGIN + BUMP := BUMP + 1; + RETURN BUMP; + END F; + + FUNCTION G RETURN INTEGER IS + BEGIN + BUMP := BUMP + 1; + G1 := BUMP; + RETURN BUMP; + END G; + + FUNCTION H RETURN INTEGER IS + BEGIN + BUMP := BUMP + 1; + H1 := BUMP; + RETURN BUMP; + END H; + +BEGIN + TEST ( "C32107C", "FOR OBJECTS OF A GENERIC FORMAL TYPE WHOSE " & + "ACTUAL PARAMETER IS A TYPE WITH DEFAULT " & + "VALUES, CHECK THAT OBJECT DECLARATIONS ARE " & + "ELABORATED IN THE ORDER OF THEIR " & + "OCCURRENCE, I.E., THAT EXPRESSIONS " & + "ASSOCIATED WITH ONE DECLARATION (INCLUDING " & + "DEFAULT EXPRESSIONS) ARE EVALUATED BEFORE " & + "ANY EXPRESSION BELONGING TO THE NEXT " & + "DECLARATION" ); + + DECLARE -- (A). + TYPE REC (D : INTEGER := F) IS + RECORD + A : INTEGER := F; + END RECORD; + + FUNCTION GET_A (R : REC) RETURN INTEGER IS + BEGIN + RETURN R.A; + END GET_A; + + GENERIC + TYPE T IS (<>); + TYPE PRIV (D : T) IS PRIVATE; + WITH FUNCTION GET_A (P : PRIV) RETURN INTEGER IS <>; + PROCEDURE P; + + PROCEDURE P IS + P1 : PRIV (T'VAL (F)); + P2 : PRIV (T'VAL (F * 100)); + ORDER_CHECK : INTEGER; + + BEGIN + ORDER_CHECK := + T'POS (P1.D) + T'POS (P2.D) + + (GET_A (P1) * 10) + (GET_A (P2) * 1000); + IF ORDER_CHECK /= 4321 THEN + FAILED ( "OBJECTS NOT ELABORATED IN PROPER " & + "ORDER VALUE OF ORDER_CHECK SHOULD BE " & + "4321 -- ACTUAL VALUE IS " & + INTEGER'IMAGE (ORDER_CHECK) & " - (A)" ); + END IF; + END P; + + PROCEDURE PROC IS NEW P (INTEGER, REC); + + BEGIN + PROC; + END; -- (A). + + BUMP := 0; + + DECLARE -- (B). + TYPE REC (D1 : INTEGER := F; D2 : INTEGER := F) IS + RECORD + A : INTEGER := F; + END RECORD; + + FUNCTION GET_A (R : REC) RETURN INTEGER IS + BEGIN + RETURN R.A; + END GET_A; + + GENERIC + TYPE T IS (<>); + TYPE PRIV (D1 : T; D2 : T) IS PRIVATE; + WITH FUNCTION GET_A (P : PRIV) RETURN INTEGER IS <>; + PROCEDURE P; + + PROCEDURE P IS + P1 : PRIV (T'VAL (F * 1000), T'VAL (F * 10000)); + P2 : PRIV (T'VAL (F), T'VAL (F * 10)); + ORDER_CHECK : INTEGER; + + BEGIN + ORDER_CHECK := + T'POS (P1.D1) + T'POS (P1.D2) + + T'POS (P2.D1) + T'POS (P2.D2) + + (GET_A (P1) * 100); + IF (GET_A (P2) = 6) AND + (ORDER_CHECK = 12345 OR ORDER_CHECK = 21345 OR + ORDER_CHECK = 21354 OR ORDER_CHECK = 12354) THEN + COMMENT ( "ORDER_CHECK HAS VALUE " & + INTEGER'IMAGE (ORDER_CHECK) & + " - (B)" ); + ELSE + FAILED ( "OBJECTS NOT ELABORATED IN PROPER " & + "ORDER VALUE OF ORDER_CHECK SHOULD BE " & + "6 12345, 6 21345, 6 21354, OR " & + "6 12354 -- ACTUAL VALUE IS " & + INTEGER'IMAGE (GET_A (P2)) & + INTEGER'IMAGE (ORDER_CHECK) & " - (B)" ); + END IF; + + END P; + + PROCEDURE PROC IS NEW P (INTEGER, REC); + + BEGIN + PROC; + END; -- (B). + + RESULT; +END C32107C; diff --git a/gcc-4.9/gcc/testsuite/ada/acats/tests/c3/c32108a.ada b/gcc-4.9/gcc/testsuite/ada/acats/tests/c3/c32108a.ada new file mode 100644 index 000000000..47423588e --- /dev/null +++ b/gcc-4.9/gcc/testsuite/ada/acats/tests/c3/c32108a.ada @@ -0,0 +1,78 @@ +-- C32108A.ADA + +-- Grant of Unlimited Rights +-- +-- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687, +-- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained +-- unlimited rights in the software and documentation contained herein. +-- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making +-- this public release, the Government intends to confer upon all +-- recipients unlimited rights equal to those held by the Government. +-- These rights include rights to use, duplicate, release or disclose the +-- released technical data and computer software in whole or in part, in +-- any manner and for any purpose whatsoever, and to have or permit others +-- to do so. +-- +-- DISCLAIMER +-- +-- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR +-- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED +-- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE +-- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE +-- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A +-- PARTICULAR PURPOSE OF SAID MATERIAL. +--* +-- CHECK THAT DEFAULT EXPRESSIONS ARE NOT EVALUATED, IF INITIALIZATION +-- EXPRESSIONS ARE GIVEN FOR THE OBJECT DECLARATIONS. + +-- TBN 3/20/86 + +WITH REPORT; USE REPORT; +PROCEDURE C32108A IS + + FUNCTION DEFAULT_CHECK (NUMBER : INTEGER) RETURN INTEGER IS + BEGIN + IF NUMBER /= 0 THEN + FAILED ("DEFAULT EXPRESSIONS ARE EVALUATED -" & + INTEGER'IMAGE (NUMBER)); + END IF; + RETURN (1); + END DEFAULT_CHECK; + +BEGIN + TEST ("C32108A", "CHECK THAT DEFAULT EXPRESSIONS ARE NOT " & + "EVALUATED, IF INITIALIZATION EXPRESSIONS ARE " & + "GIVEN FOR THE OBJECT DECLARATIONS"); + + DECLARE -- (A) + + TYPE REC_TYP1 IS + RECORD + AGE : INTEGER := DEFAULT_CHECK (1); + END RECORD; + + REC1 : REC_TYP1 := (AGE => DEFAULT_CHECK (0)); + + + TYPE REC_TYP2 (D : INTEGER := DEFAULT_CHECK (2)) IS + RECORD + NULL; + END RECORD; + + REC2 : REC_TYP2 (DEFAULT_CHECK (0)); + + + TYPE REC_TYP3 (D : INTEGER := DEFAULT_CHECK (3)) IS + RECORD + A : INTEGER := DEFAULT_CHECK (4); + END RECORD; + + REC3 : REC_TYP3 := (D => DEFAULT_CHECK (0), + A => DEFAULT_CHECK (0)); + + BEGIN -- (A) + NULL; + END; -- (A) + + RESULT; +END C32108A; diff --git a/gcc-4.9/gcc/testsuite/ada/acats/tests/c3/c32108b.ada b/gcc-4.9/gcc/testsuite/ada/acats/tests/c3/c32108b.ada new file mode 100644 index 000000000..10895788d --- /dev/null +++ b/gcc-4.9/gcc/testsuite/ada/acats/tests/c3/c32108b.ada @@ -0,0 +1,80 @@ +-- C32108B.ADA + +-- Grant of Unlimited Rights +-- +-- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687, +-- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained +-- unlimited rights in the software and documentation contained herein. +-- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making +-- this public release, the Government intends to confer upon all +-- recipients unlimited rights equal to those held by the Government. +-- These rights include rights to use, duplicate, release or disclose the +-- released technical data and computer software in whole or in part, in +-- any manner and for any purpose whatsoever, and to have or permit others +-- to do so. +-- +-- DISCLAIMER +-- +-- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR +-- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED +-- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF 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 DEFAULT EXPRESSION IS EVALUATED FOR A COMPONENT, NO +-- DEFAULT EXPRESSIONS ARE EVALUATED FOR ANY SUBCOMPONENTS. + +-- TBN 3/21/86 + +WITH REPORT; USE REPORT; +PROCEDURE C32108B IS + + FUNCTION DEFAULT_CHECK (NUMBER : INTEGER) RETURN INTEGER IS + BEGIN + IF NUMBER /= 0 THEN + FAILED ("SUBCOMPONENT DEFAULT EXPRESSIONS ARE " & + "EVALUATED -" & INTEGER'IMAGE (NUMBER)); + END IF; + RETURN (1); + END DEFAULT_CHECK; + +BEGIN + TEST ("C32108B", "CHECK THAT IF A DEFAULT EXPRESSION IS " & + "EVALUATED FOR A COMPONENT, NO DEFAULT " & + "EXPRESSIONS ARE EVALUATED FOR ANY " & + "SUBCOMPONENTS"); + + DECLARE -- (A) + + TYPE REC_TYP1 IS + RECORD + AGE : INTEGER := DEFAULT_CHECK (1); + END RECORD; + + TYPE REC_TYP2 (D : INTEGER := DEFAULT_CHECK(2)) IS + RECORD + NULL; + END RECORD; + + TYPE REC_TYP3 (D : INTEGER := DEFAULT_CHECK(3)) IS + RECORD + A : INTEGER := DEFAULT_CHECK(4); + END RECORD; + + TYPE REC_TYP4 IS + RECORD + ONE : REC_TYP1 := (AGE => DEFAULT_CHECK (0)); + TWO : REC_TYP2 (DEFAULT_CHECK(0)); + THREE : REC_TYP3 := (D => DEFAULT_CHECK (0), + A => DEFAULT_CHECK (0)); + END RECORD; + + REC4 : REC_TYP4; + + BEGIN -- (A) + NULL; + END; -- (A) + + RESULT; +END C32108B; diff --git a/gcc-4.9/gcc/testsuite/ada/acats/tests/c3/c32111a.ada b/gcc-4.9/gcc/testsuite/ada/acats/tests/c3/c32111a.ada new file mode 100644 index 000000000..3cbce0940 --- /dev/null +++ b/gcc-4.9/gcc/testsuite/ada/acats/tests/c3/c32111a.ada @@ -0,0 +1,282 @@ +-- C32111A.ADA + +-- Grant of Unlimited Rights +-- +-- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687, +-- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained +-- unlimited rights in the software and documentation contained herein. +-- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making +-- this public release, the Government intends to confer upon all +-- recipients unlimited rights equal to those held by the Government. +-- These rights include rights to use, duplicate, release or disclose the +-- released technical data and computer software in whole or in part, in +-- any manner and for any purpose whatsoever, and to have or permit others +-- to do so. +-- +-- DISCLAIMER +-- +-- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR +-- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED +-- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE +-- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE +-- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A +-- PARTICULAR PURPOSE OF SAID MATERIAL. +--* +-- OBJECTIVE: +-- CHECK THAT WHEN A VARIABLE OR CONSTANT HAVING AN ENUMERATION, +-- INTEGER, FLOAT OR FIXED TYPE IS DECLARED WITH AN INITIAL VALUE, +-- CONSTRAINT_ERROR IS RAISED IF THE INITIAL VALUE LIES OUTSIDE THE +-- RANGE OF THE SUBTYPE. + +-- HISTORY: +-- RJW 07/20/86 CREATED ORIGINAL TEST. +-- JET 08/04/87 IMPROVED DEFEAT OF COMPILER OPTIMIZATION. + +WITH REPORT; USE REPORT; + +PROCEDURE C32111A IS + + TYPE WEEKDAY IS (MON, TUES, WED, THURS, FRI); + SUBTYPE MIDWEEK IS WEEKDAY RANGE WED .. WED; + + SUBTYPE DIGIT IS CHARACTER RANGE '0' .. '9'; + + SUBTYPE SHORT IS INTEGER RANGE -100 .. 100; + + TYPE INT IS RANGE -10 .. 10; + SUBTYPE PINT IS INT RANGE 1 .. 10; + + TYPE FLT IS DIGITS 3 RANGE -5.0 .. 5.0; + SUBTYPE SFLT IS FLT RANGE -5.0 .. 0.0; + + TYPE FIXED IS DELTA 0.5 RANGE -5.0 .. 5.0; + SUBTYPE SFIXED IS FIXED RANGE 0.0 .. 5.0; + +BEGIN + TEST ("C32111A", "CHECK THAT WHEN A VARIABLE OR CONSTANT " & + "HAVING AN ENUMERATION, INTEGER, FLOAT OR " & + "FIXED TYPE IS DECLARED WITH AN INITIAL " & + "VALUE, CONSTRAINT_ERROR IS RAISED IF THE " & + "INITIAL VALUE LIES OUTSIDE THE RANGE OF THE " & + "SUBTYPE" ); + + BEGIN + DECLARE + D : MIDWEEK := WEEKDAY'VAL (IDENT_INT (1)); + BEGIN + FAILED ( "NO EXCEPTION RAISED FOR INITIALIZATION " & + "OF VARIABLE 'D'" ); + IF D = TUES THEN + COMMENT ("VARIABLE 'D' INITIALIZED"); + END IF; + END; + EXCEPTION + WHEN CONSTRAINT_ERROR => + NULL; + WHEN OTHERS => + FAILED ( "WRONG EXCEPTION RAISED FOR INITIALIZATION " & + "OF VARIABLE 'D'" ); + END; + + BEGIN + DECLARE + D : CONSTANT WEEKDAY RANGE WED .. WED := + WEEKDAY'VAL (IDENT_INT (3)); + BEGIN + FAILED ( "NO EXCEPTION RAISED FOR INITIALIZATION " & + "OF CONSTANT 'D'" ); + IF D = TUES THEN + COMMENT ("INITIALIZE VARIABLE 'D'"); + END IF; + END; + EXCEPTION + WHEN CONSTRAINT_ERROR => + NULL; + WHEN OTHERS => + FAILED ( "WRONG EXCEPTION RAISED FOR INITIALIZATION " & + "OF CONSTANT 'D'" ); + END; + + BEGIN + DECLARE + P : CONSTANT DIGIT := IDENT_CHAR ('/'); + BEGIN + FAILED ( "NO EXCEPTION RAISED FOR INITIALIZATION " & + "OF CONSTANT 'P'" ); + IF P = '0' THEN + COMMENT ("VARIABLE 'P' INITIALIZED"); + END IF; + END; + EXCEPTION + WHEN CONSTRAINT_ERROR => + NULL; + WHEN OTHERS => + FAILED ( "WRONG EXCEPTION RAISED FOR INITIALIZATION " & + "OF CONSTANT 'P'" ); + END; + + BEGIN + DECLARE + Q : CHARACTER RANGE 'A' .. 'E' := IDENT_CHAR ('F'); + BEGIN + FAILED ( "NO EXCEPTION RAISED FOR INITIALIZATION " & + "OF VARIABLE 'Q'" ); + IF Q = 'A' THEN + COMMENT ("VARIABLE 'Q' INITIALIZED"); + END IF; + END; + EXCEPTION + WHEN CONSTRAINT_ERROR => + NULL; + WHEN OTHERS => + FAILED ( "WRONG EXCEPTION RAISED FOR INITIALIZATION " & + "OF VARIABLE 'Q'" ); + END; + + BEGIN + DECLARE + I : SHORT := IDENT_INT (-101); + BEGIN + FAILED ( "NO EXCEPTION RAISED FOR INITIALIZATION " & + "OF VARIABLE 'I'" ); + IF I = 1 THEN + COMMENT ("VARIABLE 'I' INITIALIZED"); + END IF; + END; + EXCEPTION + WHEN CONSTRAINT_ERROR => + NULL; + WHEN OTHERS => + FAILED ( "WRONG EXCEPTION RAISED FOR INITIALIZATION " & + "OF VARIABLE 'I'" ); + END; + + BEGIN + DECLARE + J : CONSTANT INTEGER RANGE 0 .. 100 := IDENT_INT (101); + BEGIN + FAILED ( "NO EXCEPTION RAISED FOR INITIALIZATION " & + "OF CONSTANT 'J'" ); + IF J = -1 THEN + COMMENT ("VARIABLE 'J' INITIALIZED"); + END IF; + END; + EXCEPTION + WHEN CONSTRAINT_ERROR => + NULL; + WHEN OTHERS => + FAILED ( "WRONG EXCEPTION RAISED FOR INITIALIZATION " & + "OF CONSTANT 'J'" ); + END; + + BEGIN + DECLARE + K : INT RANGE 0 .. 1 := INT (IDENT_INT (2)); + BEGIN + FAILED ( "NO EXCEPTION RAISED FOR INITIALIZATION " & + "OF VARIABLE 'K'" ); + IF K = 2 THEN + COMMENT ("VARIABLE 'K' INITIALIZED"); + END IF; + END; + EXCEPTION + WHEN CONSTRAINT_ERROR => + NULL; + WHEN OTHERS => + FAILED ( "WRONG EXCEPTION RAISED FOR INITIALIZATION " & + "OF VARIABLE 'K'" ); + END; + + BEGIN + DECLARE + L : CONSTANT PINT := INT (IDENT_INT (0)); + BEGIN + FAILED ( "NO EXCEPTION RAISED FOR INITIALIZATION " & + "OF CONSTANT 'L'" ); + IF L = 1 THEN + COMMENT ("VARIABLE 'L' INITIALIZED"); + END IF; + END; + EXCEPTION + WHEN CONSTRAINT_ERROR => + NULL; + WHEN OTHERS => + FAILED ( "WRONG EXCEPTION RAISED FOR INITIALIZATION " & + "OF CONSTANT 'L'" ); + END; + + BEGIN + DECLARE + FL : SFLT := FLT (IDENT_INT (1)); + BEGIN + FAILED ( "NO EXCEPTION RAISED FOR INITIALIZATION " & + "OF VARIABLE 'FL'" ); + IF FL = 3.14 THEN + COMMENT ("VARIABLE 'FL' INITIALIZED"); + END IF; + END; + EXCEPTION + WHEN CONSTRAINT_ERROR => + NULL; + WHEN OTHERS => + FAILED ( "WRONG EXCEPTION RAISED FOR INITIALIZATION " & + "OF VARIABLE 'FL'" ); + END; + + BEGIN + DECLARE + FL1 : CONSTANT FLT RANGE 0.0 .. 0.0 := + FLT (IDENT_INT (-1)); + BEGIN + FAILED ( "NO EXCEPTION RAISED FOR INITIALIZATION " & + "OF CONSTANT 'FL1'" ); + IF FL1 = 0.0 THEN + COMMENT ("VARIABLE 'FL1' INITIALIZED"); + END IF; + END; + EXCEPTION + WHEN CONSTRAINT_ERROR => + NULL; + WHEN OTHERS => + FAILED ( "WRONG EXCEPTION RAISED FOR INITIALIZATION " & + "OF CONSTANT 'FL1'" ); + END; + + BEGIN + DECLARE + FI : FIXED RANGE 0.0 .. 0.0 := IDENT_INT (1) * 0.5; + BEGIN + FAILED ( "NO EXCEPTION RAISED FOR INITIALIZATION " & + "OF VARIABLE 'FI'" ); + IF FI = 0.5 THEN + COMMENT ("VARIABLE 'FI' INITIALIZED"); + END IF; + END; + EXCEPTION + WHEN CONSTRAINT_ERROR => + NULL; + WHEN OTHERS => + FAILED ( "WRONG EXCEPTION RAISED FOR INITIALIZATION " & + "OF VARIABLE 'FI'" ); + END; + + BEGIN + DECLARE + FI1 : CONSTANT SFIXED := IDENT_INT (-1) * 0.5; + BEGIN + FAILED ( "NO EXCEPTION RAISED FOR INITIALIZATION " & + "OF CONSTANT 'FI1'" ); + IF FI1 = 0.5 THEN + COMMENT ("VARIABLE 'FI1' INITIALIZED"); + END IF; + END; + EXCEPTION + WHEN CONSTRAINT_ERROR => + NULL; + WHEN OTHERS => + FAILED ( "WRONG EXCEPTION RAISED FOR INITIALIZATION " & + "OF CONSTANT 'FI1'" ); + END; + + RESULT; +END C32111A; diff --git a/gcc-4.9/gcc/testsuite/ada/acats/tests/c3/c32111b.ada b/gcc-4.9/gcc/testsuite/ada/acats/tests/c3/c32111b.ada new file mode 100644 index 000000000..85ff55e5d --- /dev/null +++ b/gcc-4.9/gcc/testsuite/ada/acats/tests/c3/c32111b.ada @@ -0,0 +1,282 @@ +-- C32111B.ADA + +-- Grant of Unlimited Rights +-- +-- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687, +-- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained +-- unlimited rights in the software and documentation contained herein. +-- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making +-- this public release, the Government intends to confer upon all +-- recipients unlimited rights equal to those held by the Government. +-- These rights include rights to use, duplicate, release or disclose the +-- released technical data and computer software in whole or in part, in +-- any manner and for any purpose whatsoever, and to have or permit others +-- to do so. +-- +-- DISCLAIMER +-- +-- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR +-- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED +-- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE +-- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE +-- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A +-- PARTICULAR PURPOSE OF SAID MATERIAL. +--* +-- OBJECTIVE: +-- CHECK THAT WHEN A VARIABLE OR CONSTANT HAVING AN ENUMERATION, +-- INTEGER, FLOAT OR FIXED TYPE IS DECLARED WITH AN INITIAL STATIC +-- VALUE, CONSTRAINT_ERROR IS RAISED IF THE INITIAL VALUE LIES +-- OUTSIDE THE RANGE OF THE SUBTYPE. + +-- HISTORY: +-- JET 08/04/87 CREATED ORIGINAL TEST BASED ON C32111A BY RJW +-- BUT WITH STATIC VALUES INSTEAD OF DYNAMIC +-- IDENTITY FUNCTION. + +WITH REPORT; USE REPORT; + +PROCEDURE C32111B IS + + TYPE WEEKDAY IS (MON, TUES, WED, THURS, FRI); + SUBTYPE MIDWEEK IS WEEKDAY RANGE WED .. WED; + + SUBTYPE DIGIT IS CHARACTER RANGE '0' .. '9'; + + SUBTYPE SHORT IS INTEGER RANGE -100 .. 100; + + TYPE INT IS RANGE -10 .. 10; + SUBTYPE PINT IS INT RANGE 1 .. 10; + + TYPE FLT IS DIGITS 3 RANGE -5.0 .. 5.0; + SUBTYPE SFLT IS FLT RANGE -5.0 .. 0.0; + + TYPE FIXED IS DELTA 0.5 RANGE -5.0 .. 5.0; + SUBTYPE SFIXED IS FIXED RANGE 0.0 .. 5.0; + +BEGIN + TEST ("C32111B", "CHECK THAT WHEN A VARIABLE OR CONSTANT " & + "HAVING AN ENUMERATION, INTEGER, FLOAT OR " & + "FIXED TYPE IS DECLARED WITH AN INITIAL STATIC " & + "VALUE, CONSTRAINT_ERROR IS RAISED IF THE " & + "INITIAL VALUE LIES OUTSIDE THE RANGE OF THE " & + "SUBTYPE" ); + + BEGIN + DECLARE + D : MIDWEEK := WEEKDAY'VAL (1); + BEGIN + FAILED ( "NO EXCEPTION RAISED FOR INITIALIZATION " & + "OF VARIABLE 'D'" ); + IF D = TUES THEN + COMMENT ("VARIABLE 'D' INITIALIZED"); + END IF; + END; + EXCEPTION + WHEN CONSTRAINT_ERROR => + NULL; + WHEN OTHERS => + FAILED ( "WRONG EXCEPTION RAISED FOR INITIALIZATION " & + "OF VARIABLE 'D'" ); + END; + + BEGIN + DECLARE + D : CONSTANT WEEKDAY RANGE WED .. WED := + WEEKDAY'VAL (3); + BEGIN + FAILED ( "NO EXCEPTION RAISED FOR INITIALIZATION " & + "OF CONSTANT 'D'" ); + IF D = TUES THEN + COMMENT ("INITIALIZE VARIABLE 'D'"); + END IF; + END; + EXCEPTION + WHEN CONSTRAINT_ERROR => + NULL; + WHEN OTHERS => + FAILED ( "WRONG EXCEPTION RAISED FOR INITIALIZATION " & + "OF CONSTANT 'D'" ); + END; + + BEGIN + DECLARE + P : CONSTANT DIGIT := '/'; + BEGIN + FAILED ( "NO EXCEPTION RAISED FOR INITIALIZATION " & + "OF CONSTANT 'P'" ); + IF P = '0' THEN + COMMENT ("VARIABLE 'P' INITIALIZED"); + END IF; + END; + EXCEPTION + WHEN CONSTRAINT_ERROR => + NULL; + WHEN OTHERS => + FAILED ( "WRONG EXCEPTION RAISED FOR INITIALIZATION " & + "OF CONSTANT 'P'" ); + END; + + BEGIN + DECLARE + Q : CHARACTER RANGE 'A' .. 'E' := 'F'; + BEGIN + FAILED ( "NO EXCEPTION RAISED FOR INITIALIZATION " & + "OF VARIABLE 'Q'" ); + IF Q = 'A' THEN + COMMENT ("VARIABLE 'Q' INITIALIZED"); + END IF; + END; + EXCEPTION + WHEN CONSTRAINT_ERROR => + NULL; + WHEN OTHERS => + FAILED ( "WRONG EXCEPTION RAISED FOR INITIALIZATION " & + "OF VARIABLE 'Q'" ); + END; + + BEGIN + DECLARE + I : SHORT := -101; + BEGIN + FAILED ( "NO EXCEPTION RAISED FOR INITIALIZATION " & + "OF VARIABLE 'I'" ); + IF I = 1 THEN + COMMENT ("VARIABLE 'I' INITIALIZED"); + END IF; + END; + EXCEPTION + WHEN CONSTRAINT_ERROR => + NULL; + WHEN OTHERS => + FAILED ( "WRONG EXCEPTION RAISED FOR INITIALIZATION " & + "OF VARIABLE 'I'" ); + END; + + BEGIN + DECLARE + J : CONSTANT INTEGER RANGE 0 .. 100 := 101; + BEGIN + FAILED ( "NO EXCEPTION RAISED FOR INITIALIZATION " & + "OF CONSTANT 'J'" ); + IF J = -1 THEN + COMMENT ("VARIABLE 'J' INITIALIZED"); + END IF; + END; + EXCEPTION + WHEN CONSTRAINT_ERROR => + NULL; + WHEN OTHERS => + FAILED ( "WRONG EXCEPTION RAISED FOR INITIALIZATION " & + "OF CONSTANT 'J'" ); + END; + + BEGIN + DECLARE + K : INT RANGE 0 .. 1 := 2; + BEGIN + FAILED ( "NO EXCEPTION RAISED FOR INITIALIZATION " & + "OF VARIABLE 'K'" ); + IF K = 2 THEN + COMMENT ("VARIABLE 'K' INITIALIZED"); + END IF; + END; + EXCEPTION + WHEN CONSTRAINT_ERROR => + NULL; + WHEN OTHERS => + FAILED ( "WRONG EXCEPTION RAISED FOR INITIALIZATION " & + "OF VARIABLE 'K'" ); + END; + + BEGIN + DECLARE + L : CONSTANT PINT := 0; + BEGIN + FAILED ( "NO EXCEPTION RAISED FOR INITIALIZATION " & + "OF CONSTANT 'L'" ); + IF L = 1 THEN + COMMENT ("VARIABLE 'L' INITIALIZED"); + END IF; + END; + EXCEPTION + WHEN CONSTRAINT_ERROR => + NULL; + WHEN OTHERS => + FAILED ( "WRONG EXCEPTION RAISED FOR INITIALIZATION " & + "OF CONSTANT 'L'" ); + END; + + BEGIN + DECLARE + FL : SFLT := 1.0; + BEGIN + FAILED ( "NO EXCEPTION RAISED FOR INITIALIZATION " & + "OF VARIABLE 'FL'" ); + IF FL = 3.14 THEN + COMMENT ("VARIABLE 'FL' INITIALIZED"); + END IF; + END; + EXCEPTION + WHEN CONSTRAINT_ERROR => + NULL; + WHEN OTHERS => + FAILED ( "WRONG EXCEPTION RAISED FOR INITIALIZATION " & + "OF VARIABLE 'FL'" ); + END; + + BEGIN + DECLARE + FL1 : CONSTANT FLT RANGE 0.0 .. 0.0 := -1.0; + BEGIN + FAILED ( "NO EXCEPTION RAISED FOR INITIALIZATION " & + "OF CONSTANT 'FL1'" ); + IF FL1 = 0.0 THEN + COMMENT ("VARIABLE 'FL1' INITIALIZED"); + END IF; + END; + EXCEPTION + WHEN CONSTRAINT_ERROR => + NULL; + WHEN OTHERS => + FAILED ( "WRONG EXCEPTION RAISED FOR INITIALIZATION " & + "OF CONSTANT 'FL1'" ); + END; + + BEGIN + DECLARE + FI : FIXED RANGE 0.0 .. 0.0 := 0.5; + BEGIN + FAILED ( "NO EXCEPTION RAISED FOR INITIALIZATION " & + "OF VARIABLE 'FI'" ); + IF FI = 0.5 THEN + COMMENT ("VARIABLE 'FI' INITIALIZED"); + END IF; + END; + EXCEPTION + WHEN CONSTRAINT_ERROR => + NULL; + WHEN OTHERS => + FAILED ( "WRONG EXCEPTION RAISED FOR INITIALIZATION " & + "OF VARIABLE 'FI'" ); + END; + + BEGIN + DECLARE + FI1 : CONSTANT SFIXED := -0.5; + BEGIN + FAILED ( "NO EXCEPTION RAISED FOR INITIALIZATION " & + "OF CONSTANT 'FI1'" ); + IF FI1 = 0.5 THEN + COMMENT ("VARIABLE 'FI1' INITIALIZED"); + END IF; + END; + EXCEPTION + WHEN CONSTRAINT_ERROR => + NULL; + WHEN OTHERS => + FAILED ( "WRONG EXCEPTION RAISED FOR INITIALIZATION " & + "OF CONSTANT 'FI1'" ); + END; + + RESULT; +END C32111B; diff --git a/gcc-4.9/gcc/testsuite/ada/acats/tests/c3/c32112b.ada b/gcc-4.9/gcc/testsuite/ada/acats/tests/c3/c32112b.ada new file mode 100644 index 000000000..e2aeeb6d7 --- /dev/null +++ b/gcc-4.9/gcc/testsuite/ada/acats/tests/c3/c32112b.ada @@ -0,0 +1,267 @@ +-- C32112B.ADA + +-- Grant of Unlimited Rights +-- +-- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687, +-- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained +-- unlimited rights in the software and documentation contained herein. +-- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making +-- this public release, the Government intends to confer upon all +-- recipients unlimited rights equal to those held by the Government. +-- These rights include rights to use, duplicate, release or disclose the +-- released technical data and computer software in whole or in part, in +-- any manner and for any purpose whatsoever, and to have or permit others +-- to do so. +-- +-- DISCLAIMER +-- +-- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR +-- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED +-- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE +-- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE +-- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A +-- PARTICULAR PURPOSE OF SAID MATERIAL. +--* +-- CHECK THAT CONSTRAINT_ERROR IS RAISED FOR THE DECLARATION OF A NULL +-- ARRAY OBJECT IF THE INITIAL VALUE IS NOT A NULL ARRAY. + +-- RJW 7/20/86 +-- GMT 7/01/87 ADDED CODE TO PREVENT DEAD VARIABLE OPTIMIZATION. +-- CHANGED THE RANGE VALUES OF A FEW DIMENSIONS. + +WITH REPORT; USE REPORT; + +PROCEDURE C32112B IS + + TYPE ARR1 IS ARRAY (NATURAL RANGE <>) OF INTEGER; + SUBTYPE NARR1 IS ARR1 (IDENT_INT (2) .. IDENT_INT (1)); + + + TYPE ARR2 IS ARRAY (NATURAL RANGE <>, NATURAL RANGE <>) + OF INTEGER; + SUBTYPE NARR2 IS ARR2 (IDENT_INT (1) .. IDENT_INT (2), + IDENT_INT (1) .. IDENT_INT (0)); + +BEGIN + TEST ("C32112B", "CHECK THAT CONSTRAINT_ERROR IS RAISED FOR " & + "THE DECLARATION OF A NULL ARRAY OBJECT IF " & + "THE INITIAL VALUE IS NOT A NULL ARRAY"); + + BEGIN + DECLARE + A : ARR1 (IDENT_INT(1) .. IDENT_INT(2)); + N1A : NARR1 := (A'RANGE => 0); + BEGIN + FAILED ("NO EXCEPTION RAISED FOR INITIALIZATION " & + "OF VARIABLE 'N1A'"); + A(1) := IDENT_INT(N1A(1)); + END; + EXCEPTION + WHEN CONSTRAINT_ERROR => + NULL; + WHEN OTHERS => + FAILED ("WRONG EXCEPTION RAISED FOR INITIALIZATION " & + "OF VARIABLE 'N1A'"); + END; + + BEGIN + DECLARE + A : ARR1 (IDENT_INT (1) .. IDENT_INT (2)); + N1B : CONSTANT NARR1 := (A'RANGE => 0); + BEGIN + FAILED ("NO EXCEPTION RAISED FOR INITIALIZATION " & + "OF CONSTANT 'N1B'"); + A(1) := IDENT_INT(N1B(1)); + END; + EXCEPTION + WHEN CONSTRAINT_ERROR => + NULL; + WHEN OTHERS => + FAILED ("WRONG EXCEPTION RAISED FOR INITIALIZATION " & + "OF CONSTANT 'N1B'"); + END; + + BEGIN + DECLARE + A : ARR1 (IDENT_INT (1) .. IDENT_INT (1)); + N1C : CONSTANT NARR1 := (A'RANGE => 0); + BEGIN + FAILED ("NO EXCEPTION RAISED FOR INITIALIZATION " & + "OF CONSTANT 'N1C'"); + A(1) := IDENT_INT(N1C(1)); + END; + EXCEPTION + WHEN CONSTRAINT_ERROR => + NULL; + WHEN OTHERS => + FAILED ("WRONG EXCEPTION RAISED FOR INITIALIZATION " & + "OF CONSTANT 'N1C'"); + END; + + BEGIN + DECLARE + A : ARR1 (IDENT_INT (1) .. IDENT_INT (1)); + N1D : NARR1 := (A'RANGE => 0); + BEGIN + FAILED ("NO EXCEPTION RAISED FOR INITIALIZATION " & + "OF VARIABLE 'N1D'"); + A(1) := IDENT_INT(N1D(1)); + END; + EXCEPTION + WHEN CONSTRAINT_ERROR => + NULL; + WHEN OTHERS => + FAILED ("WRONG EXCEPTION RAISED FOR INITIALIZATION " & + "OF VARIABLE 'N1D'"); + END; + + BEGIN + DECLARE + A : ARR1 (IDENT_INT (0) .. IDENT_INT (1)); + N1E : ARR1 (IDENT_INT (1) .. IDENT_INT (0)) := + (A'RANGE => 0); + BEGIN + FAILED ("NO EXCEPTION RAISED FOR INITIALIZATION " & + "OF VARIABLE 'N1E'"); + A(1) := IDENT_INT(N1E(1)); + END; + EXCEPTION + WHEN CONSTRAINT_ERROR => + NULL; + WHEN OTHERS => + FAILED ("WRONG EXCEPTION RAISED FOR INITIALIZATION " & + "OF VARIABLE 'N1E'"); + END; + + BEGIN + DECLARE + A : ARR1 (IDENT_INT (0) .. IDENT_INT (1)); + N1F : CONSTANT ARR1 (IDENT_INT (1) .. IDENT_INT (0)) := + (A'RANGE => 0); + BEGIN + FAILED ("NO EXCEPTION RAISED FOR INITIALIZATION " & + "OF CONSTANT 'N1F'"); + A(1) := IDENT_INT(N1F(1)); + END; + EXCEPTION + WHEN CONSTRAINT_ERROR => + NULL; + WHEN OTHERS => + FAILED ("WRONG EXCEPTION RAISED FOR INITIALIZATION " & + "OF CONSTANT 'N1F'"); + END; + + BEGIN + DECLARE + A : ARR2 (IDENT_INT (1) .. IDENT_INT (2), + IDENT_INT (0) .. IDENT_INT (1)); + N2A : CONSTANT NARR2 := (A'RANGE => (A'RANGE (2) =>0)); + BEGIN + FAILED ("NO EXCEPTION RAISED FOR INITIALIZATION " & + "OF CONSTANT 'N2'"); + A(1,1) := IDENT_INT(N2A(1,1)); + END; + EXCEPTION + WHEN CONSTRAINT_ERROR => + NULL; + WHEN OTHERS => + FAILED ("WRONG EXCEPTION RAISED FOR INITIALIZATION " & + "OF CONSTANT 'N2A'"); + END; + + BEGIN + DECLARE + A : ARR2 (IDENT_INT (1) .. IDENT_INT (2), + IDENT_INT (0) .. IDENT_INT (1)); + N2B : NARR2 := (A'RANGE => (A'RANGE (2) =>0)); + BEGIN + FAILED ("NO EXCEPTION RAISED FOR INITIALIZATION " & + "OF VARIABLE 'N2B'"); + A(1,1) := IDENT_INT(N2B(1,1)); + END; + EXCEPTION + WHEN CONSTRAINT_ERROR => + NULL; + WHEN OTHERS => + FAILED ("WRONG EXCEPTION RAISED FOR INITIALIZATION " & + "OF VARIABLE 'N2B'"); + END; + + BEGIN + DECLARE + A : ARR2 (IDENT_INT (1) .. IDENT_INT (3), + IDENT_INT (1) .. IDENT_INT (1)); + N2C : CONSTANT NARR2 := (A'RANGE => (A'RANGE (2) =>0)); + BEGIN + FAILED ("NO EXCEPTION RAISED FOR INITIALIZATION " & + "OF CONSTANT 'N2C'"); + A(1,1) := IDENT_INT(N2C(1,1)); + END; + EXCEPTION + WHEN CONSTRAINT_ERROR => + NULL; + WHEN OTHERS => + FAILED ("WRONG EXCEPTION RAISED FOR INITIALIZATION " & + "OF CONSTANT 'N2C'"); + END; + + BEGIN + DECLARE + A : ARR2 (IDENT_INT (1) .. IDENT_INT (3), + IDENT_INT (1) .. IDENT_INT (1)); + N2D : NARR2 := (A'RANGE => (A'RANGE (2) =>0)); + BEGIN + FAILED ("NO EXCEPTION RAISED FOR INITIALIZATION " & + "OF VARIABLE 'N2D'"); + A(1,1) := IDENT_INT(N2D(1,1)); + END; + EXCEPTION + WHEN CONSTRAINT_ERROR => + NULL; + WHEN OTHERS => + FAILED ("WRONG EXCEPTION RAISED FOR INITIALIZATION " & + "OF VARIABLE 'N2D'"); + END; + + BEGIN + DECLARE + A : ARR2 (IDENT_INT (1) .. IDENT_INT (1), + IDENT_INT (1) .. IDENT_INT (1)); + N2E : CONSTANT ARR2 (IDENT_INT (2) .. IDENT_INT (1), + IDENT_INT (1) .. IDENT_INT (1)) := + (A'RANGE => (A'RANGE (2) =>0)); + BEGIN + FAILED ("NO EXCEPTION RAISED FOR INITIALIZATION " & + "OF CONSTANT 'N2E'"); + A(1,1) := IDENT_INT(N2E(1,1)); + END; + EXCEPTION + WHEN CONSTRAINT_ERROR => + NULL; + WHEN OTHERS => + FAILED ("WRONG EXCEPTION RAISED FOR INITIALIZATION " & + "OF CONSTANT 'N2E'"); + END; + + BEGIN + DECLARE + A : ARR2 (IDENT_INT (1) .. IDENT_INT (1), + IDENT_INT (1) .. IDENT_INT (1)); + N2F : ARR2 (IDENT_INT (2) .. IDENT_INT (1), + IDENT_INT (1) .. IDENT_INT (1)) := + (A'RANGE => (A'RANGE (2) =>0)); + BEGIN + FAILED ("NO EXCEPTION RAISED FOR INITIALIZATION " & + "OF VARIABLE 'N2F'"); + A(1,1) := IDENT_INT(N2F(1,1)); + END; + EXCEPTION + WHEN CONSTRAINT_ERROR => + NULL; + WHEN OTHERS => + FAILED ("WRONG EXCEPTION RAISED FOR INITIALIZATION " & + "OF VARIABLE 'N2F'"); + END; + + RESULT; +END C32112B; diff --git a/gcc-4.9/gcc/testsuite/ada/acats/tests/c3/c32113a.ada b/gcc-4.9/gcc/testsuite/ada/acats/tests/c3/c32113a.ada new file mode 100644 index 000000000..60f8d6690 --- /dev/null +++ b/gcc-4.9/gcc/testsuite/ada/acats/tests/c3/c32113a.ada @@ -0,0 +1,534 @@ +-- C32113A.ADA + +-- Grant of Unlimited Rights +-- +-- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687, +-- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained +-- unlimited rights in the software and documentation contained herein. +-- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making +-- this public release, the Government intends to confer upon all +-- recipients unlimited rights equal to those held by the Government. +-- These rights include rights to use, duplicate, release or disclose the +-- released technical data and computer software in whole or in part, in +-- any manner and for any purpose whatsoever, and to have or permit others +-- to do so. +-- +-- DISCLAIMER +-- +-- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR +-- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED +-- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE +-- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE +-- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A +-- PARTICULAR PURPOSE OF SAID MATERIAL. +--* +-- OBJECTIVE: +-- CHECK THAT WHEN A VARIABLE OR CONSTANT HAVING A CONSTRAINED TYPE +-- WITH DISCRIMINANTS IS DECLARED WITH AN INITIAL VALUE, +-- CONSTRAINT_ERROR IS RAISED IF THE CORRESPONDING DISCRIMINANTS OF +-- THE INITIAL VALUE AND THE SUBTYPE DO NOT HAVE THE SAME VALUE. + +-- HISTORY: +-- RJW 07/20/86 +-- DWC 06/22/87 ADDED SUBTYPE PRIVAS. ADDED CODE TO PREVENT DEAD +-- VARIABLE OPTIMIZATION. + +WITH REPORT; USE REPORT; + +PROCEDURE C32113A IS + + PACKAGE PKG IS + TYPE PRIVA (D : INTEGER := 0) IS PRIVATE; + SUBTYPE PRIVAS IS PRIVA (IDENT_INT (1)); + PRA1 : CONSTANT PRIVAS; + + TYPE PRIVB (D1, D2 : INTEGER) IS PRIVATE; + PRB12 : CONSTANT PRIVB; + + PRIVATE + TYPE PRIVA (D : INTEGER := 0) IS + RECORD + NULL; + END RECORD; + + TYPE PRIVB (D1, D2 : INTEGER) IS + RECORD + NULL; + END RECORD; + + PRA1 : CONSTANT PRIVAS := (D => (IDENT_INT (1))); + PRB12 : CONSTANT PRIVB := (IDENT_INT (1), IDENT_INT (2)); + END PKG; + + USE PKG; + + TYPE RECA (D : INTEGER := 0) IS + RECORD + NULL; + END RECORD; + + TYPE RECB (D1, D2 : INTEGER) IS + RECORD + NULL; + END RECORD; + + RA1 : CONSTANT RECA (IDENT_INT (1)) := (D => (IDENT_INT (1))); + + RB12 : CONSTANT RECB := (IDENT_INT (1), IDENT_INT (2)); + +BEGIN + TEST ("C32113A", "CHECK THAT WHEN A VARIABLE OR CONSTANT " & + "HAVING A CONSTRAINED TYPE IS DECLARED WITH " & + "AN INITIAL VALUE, CONSTRAINT_ERROR IS " & + "RAISED IF THE CORRESPONDING DISCRIMINANTS " & + "OF THE INITIAL VALUE AND THE SUBTYPE DO " & + "NOT HAVE THE SAME VALUE" ); + + BEGIN + DECLARE + PR1 : CONSTANT PRIVA (IDENT_INT (0)) := PRA1; + BEGIN + FAILED ( "NO EXCEPTION RAISED FOR INITIALIZATION " & + "OF CONSTANT 'PR1'" ); + IF PR1 = PRA1 THEN + COMMENT ("PREVENTING DEAD VARIABLE OPTIMIZATION"); + END IF; + END; + EXCEPTION + WHEN CONSTRAINT_ERROR => + NULL; + WHEN OTHERS => + FAILED ( "WRONG EXCEPTION RAISED FOR INITIALIZATION " & + "OF CONSTANT 'PR1'" ); + END; + + BEGIN + DECLARE + PR2 : CONSTANT PRIVA (IDENT_INT (2)) := PRA1; + BEGIN + FAILED ( "NO EXCEPTION RAISED FOR INITIALIZATION " & + "OF CONSTANT 'PR2'" ); + IF PR2 = PRA1 THEN + COMMENT ("PREVENTING DEAD VARIABLE OPTIMIZATION"); + END IF; + END; + EXCEPTION + WHEN CONSTRAINT_ERROR => + NULL; + WHEN OTHERS => + FAILED ( "WRONG EXCEPTION RAISED FOR INITIALIZATION " & + "OF CONSTANT 'PR2'" ); + END; + + BEGIN + DECLARE + PR3 : PRIVA (IDENT_INT (0)) := PRA1; + BEGIN + FAILED ( "NO EXCEPTION RAISED FOR INITIALIZATION " & + "OF VARIABLE 'PR3'" ); + IF PR3 = PRA1 THEN + COMMENT ("PREVENTING DEAD VARIABLE OPTIMIZATION"); + END IF; + END; + EXCEPTION + WHEN CONSTRAINT_ERROR => + NULL; + WHEN OTHERS => + FAILED ( "WRONG EXCEPTION RAISED FOR INITIALIZATION " & + "OF VARIABLE 'PR3'" ); + END; + + BEGIN + DECLARE + PR4 : PRIVA (IDENT_INT (2)) := PRA1; + BEGIN + FAILED ( "NO EXCEPTION RAISED FOR INITIALIZATION " & + "OF VARIABLE 'PR4'" ); + IF PR4 = PRA1 THEN + COMMENT ("PREVENTING DEAD VARIABLE OPTIMIZATION"); + END IF; + END; + EXCEPTION + WHEN CONSTRAINT_ERROR => + NULL; + WHEN OTHERS => + FAILED ( "WRONG EXCEPTION RAISED FOR INITIALIZATION " & + "OF VARIABLE 'PR4'" ); + END; + + BEGIN + DECLARE + SUBTYPE SPRIVA IS PRIVA (IDENT_INT (-1)); + PR5 : CONSTANT SPRIVA := PRA1; + BEGIN + FAILED ( "NO EXCEPTION RAISED FOR INITIALIZATION " & + "OF CONSTANT 'PR5'" ); + IF PR5 = PRA1 THEN + COMMENT ("PREVENTING DEAD VARIABLE OPTIMIZATION"); + END IF; + END; + EXCEPTION + WHEN CONSTRAINT_ERROR => + NULL; + WHEN OTHERS => + FAILED ( "WRONG EXCEPTION RAISED FOR INITIALIZATION " & + "OF CONSTANT 'PR5'" ); + END; + + BEGIN + DECLARE + SUBTYPE SPRIVA IS PRIVA (IDENT_INT (3)); + PR6 : SPRIVA := PRA1; + BEGIN + FAILED ( "NO EXCEPTION RAISED FOR INITIALIZATION " & + "OF VARIABLE 'PR6'" ); + IF PR6 = PRA1 THEN + COMMENT ("PREVENTING DEAD VARIABLE OPTIMIZATION"); + END IF; + END; + EXCEPTION + WHEN CONSTRAINT_ERROR => + NULL; + WHEN OTHERS => + FAILED ( "WRONG EXCEPTION RAISED FOR INITIALIZATION " & + "OF VARIABLE 'PR6'" ); + END; + + BEGIN + DECLARE + PR7 : CONSTANT PRIVB (IDENT_INT (1), IDENT_INT (1)) := + PRB12; + BEGIN + FAILED ( "NO EXCEPTION RAISED FOR INITIALIZATION " & + "OF CONSTANT 'PR7'" ); + IF PR7 = PRB12 THEN + COMMENT ("PREVENTING DEAD VARIABLE OPTIMIZATION"); + END IF; + END; + EXCEPTION + WHEN CONSTRAINT_ERROR => + NULL; + WHEN OTHERS => + FAILED ( "WRONG EXCEPTION RAISED FOR INITIALIZATION " & + "OF CONSTANT 'PR7'" ); + END; + + BEGIN + DECLARE + PR8 : CONSTANT PRIVB (IDENT_INT (2), IDENT_INT (2)) := + PRB12; + BEGIN + FAILED ( "NO EXCEPTION RAISED FOR INITIALIZATION " & + "OF CONSTANT 'PR8'" ); + IF PR8 = PRB12 THEN + COMMENT ("PREVENTING DEAD VARIABLE OPTIMIZATION"); + END IF; + END; + EXCEPTION + WHEN CONSTRAINT_ERROR => + NULL; + WHEN OTHERS => + FAILED ( "WRONG EXCEPTION RAISED FOR INITIALIZATION " & + "OF CONSTANT 'PR8'" ); + END; + + BEGIN + DECLARE + PR9 : PRIVB (IDENT_INT (1), IDENT_INT (1)) := PRB12; + BEGIN + FAILED ( "NO EXCEPTION RAISED FOR INITIALIZATION " & + "OF VARIABLE 'PR9'" ); + IF PR9 = PRB12 THEN + COMMENT ("PREVENTING DEAD VARIABLE OPTIMIZATION"); + END IF; + END; + EXCEPTION + WHEN CONSTRAINT_ERROR => + NULL; + WHEN OTHERS => + FAILED ( "WRONG EXCEPTION RAISED FOR INITIALIZATION " & + "OF VARIABLE 'PR9'" ); + END; + + BEGIN + DECLARE + PR10 : PRIVB (IDENT_INT (2), IDENT_INT (2)) := PRB12; + BEGIN + FAILED ( "NO EXCEPTION RAISED FOR INITIALIZATION " & + "OF VARIABLE 'PR10'" ); + IF PR10 = PRB12 THEN + COMMENT ("PREVENTING DEAD VARIABLE OPTIMIZATION"); + END IF; + END; + EXCEPTION + WHEN CONSTRAINT_ERROR => + NULL; + WHEN OTHERS => + FAILED ( "WRONG EXCEPTION RAISED FOR INITIALIZATION " & + "OF VARIABLE 'PR10'" ); + END; + + BEGIN + DECLARE + SUBTYPE SPRIVB IS + PRIVB (IDENT_INT (-1), IDENT_INT (-2)); + PR11 : CONSTANT SPRIVB := PRB12; + BEGIN + FAILED ( "NO EXCEPTION RAISED FOR INITIALIZATION " & + "OF CONSTANT 'PR11'" ); + IF PR11 = PRB12 THEN + COMMENT ("PREVENTING DEAD VARIABLE OPTIMIZATION"); + END IF; + END; + EXCEPTION + WHEN CONSTRAINT_ERROR => + NULL; + WHEN OTHERS => + FAILED ( "WRONG EXCEPTION RAISED FOR INITIALIZATION " & + "OF CONSTANT 'PR11'" ); + END; + + BEGIN + DECLARE + SUBTYPE SPRIVB IS PRIVB (IDENT_INT (2), IDENT_INT (1)); + PR12 : SPRIVB := PRB12; + BEGIN + FAILED ( "NO EXCEPTION RAISED FOR INITIALIZATION " & + "OF VARIABLE 'PR12'" ); + IF PR12 = PRB12 THEN + COMMENT ("PREVENTING DEAD VARIABLE OPTIMIZATION"); + END IF; + END; + EXCEPTION + WHEN CONSTRAINT_ERROR => + NULL; + WHEN OTHERS => + FAILED ( "WRONG EXCEPTION RAISED FOR INITIALIZATION " & + "OF VARIABLE 'PR12'" ); + END; + + BEGIN + DECLARE + R1 : CONSTANT RECA (IDENT_INT (0)) := RA1; + BEGIN + FAILED ( "NO EXCEPTION RAISED FOR INITIALIZATION " & + "OF CONSTANT 'R1'" ); + IF R1 = RA1 THEN + COMMENT ("PREVENTING DEAD VARIABLE OPTIMIZATION"); + END IF; + END; + EXCEPTION + WHEN CONSTRAINT_ERROR => + NULL; + WHEN OTHERS => + FAILED ( "WRONG EXCEPTION RAISED FOR INITIALIZATION " & + "OF CONSTANT 'R1'" ); + END; + + BEGIN + DECLARE + R2 : CONSTANT RECA (IDENT_INT (2)) := RA1; + BEGIN + FAILED ( "NO EXCEPTION RAISED FOR INITIALIZATION " & + "OF CONSTANT 'R2'" ); + IF R2 = RA1 THEN + COMMENT ("PREVENTING DEAD VARIABLE OPTIMIZATION"); + END IF; + END; + EXCEPTION + WHEN CONSTRAINT_ERROR => + NULL; + WHEN OTHERS => + FAILED ( "WRONG EXCEPTION RAISED FOR INITIALIZATION " & + "OF CONSTANT 'R2'" ); + END; + + BEGIN + DECLARE + R3 : RECA (IDENT_INT (0)) := RA1; + BEGIN + FAILED ( "NO EXCEPTION RAISED FOR INITIALIZATION " & + "OF VARIABLE 'R3'" ); + IF R3 = RA1 THEN + COMMENT ("PREVENTING DEAD VARIABLE OPTIMIZATION"); + END IF; + END; + EXCEPTION + WHEN CONSTRAINT_ERROR => + NULL; + WHEN OTHERS => + FAILED ( "WRONG EXCEPTION RAISED FOR INITIALIZATION " & + "OF VARIABLE 'R3'" ); + END; + + BEGIN + DECLARE + R4 : RECA (IDENT_INT (2)) := RA1; + BEGIN + FAILED ( "NO EXCEPTION RAISED FOR INITIALIZATION " & + "OF VARIABLE 'R4'" ); + IF R4 = RA1 THEN + COMMENT ("PREVENTING DEAD VARIABLE OPTIMIZATION"); + END IF; + END; + EXCEPTION + WHEN CONSTRAINT_ERROR => + NULL; + WHEN OTHERS => + FAILED ( "WRONG EXCEPTION RAISED FOR INITIALIZATION " & + "OF VARIABLE 'R4'" ); + END; + + BEGIN + DECLARE + SUBTYPE SRECA IS RECA (IDENT_INT (-1)); + R5 : CONSTANT SRECA := RA1; + BEGIN + FAILED ( "NO EXCEPTION RAISED FOR INITIALIZATION " & + "OF CONSTANT 'R5'" ); + IF R5 = RA1 THEN + COMMENT ("PREVENTING DEAD VARIABLE OPTIMIZATION"); + END IF; + END; + EXCEPTION + WHEN CONSTRAINT_ERROR => + NULL; + WHEN OTHERS => + FAILED ( "WRONG EXCEPTION RAISED FOR INITIALIZATION " & + "OF CONSTANT 'R5'" ); + END; + + BEGIN + DECLARE + SUBTYPE SRECA IS RECA (IDENT_INT (3)); + R6 : SRECA := RA1; + BEGIN + FAILED ( "NO EXCEPTION RAISED FOR INITIALIZATION " & + "OF VARIABLE 'R6'" ); + IF R6 = RA1 THEN + COMMENT ("PREVENTING DEAD VARIABLE OPTIMIZATION"); + END IF; + END; + EXCEPTION + WHEN CONSTRAINT_ERROR => + NULL; + WHEN OTHERS => + FAILED ( "WRONG EXCEPTION RAISED FOR INITIALIZATION " & + "OF VARIABLE 'R6'" ); + END; + + BEGIN + DECLARE + R7 : CONSTANT RECB (IDENT_INT (1), IDENT_INT (1)) := + RB12; + BEGIN + FAILED ( "NO EXCEPTION RAISED FOR INITIALIZATION " & + "OF CONSTANT 'R7'" ); + IF R7 = RB12 THEN + COMMENT ("PREVENTING DEAD VARIABLE OPTIMIZATION"); + END IF; + END; + EXCEPTION + WHEN CONSTRAINT_ERROR => + NULL; + WHEN OTHERS => + FAILED ( "WRONG EXCEPTION RAISED FOR INITIALIZATION " & + "OF CONSTANT 'R7'" ); + END; + + BEGIN + DECLARE + R8 : CONSTANT RECB (IDENT_INT (2), IDENT_INT (2)) := + RB12; + BEGIN + FAILED ( "NO EXCEPTION RAISED FOR INITIALIZATION " & + "OF CONSTANT 'R8'" ); + IF R8 = RB12 THEN + COMMENT ("PREVENTING DEAD VARIABLE OPTIMIZATION"); + END IF; + END; + EXCEPTION + WHEN CONSTRAINT_ERROR => + NULL; + WHEN OTHERS => + FAILED ( "WRONG EXCEPTION RAISED FOR INITIALIZATION " & + "OF CONSTANT 'R8'" ); + END; + + BEGIN + DECLARE + R9 : RECB (IDENT_INT (1), IDENT_INT (1)) := RB12; + BEGIN + FAILED ( "NO EXCEPTION RAISED FOR INITIALIZATION " & + "OF VARIABLE 'R9'" ); + IF R9 = RB12 THEN + COMMENT ("PREVENTING DEAD VARIABLE OPTIMIZATION"); + END IF; + END; + EXCEPTION + WHEN CONSTRAINT_ERROR => + NULL; + WHEN OTHERS => + FAILED ( "WRONG EXCEPTION RAISED FOR INITIALIZATION " & + "OF VARIABLE 'R9'" ); + END; + + BEGIN + DECLARE + R10 : RECB (IDENT_INT (2), IDENT_INT (2)) := RB12; + BEGIN + FAILED ( "NO EXCEPTION RAISED FOR INITIALIZATION " & + "OF VARIABLE 'R10'" ); + IF R10 = RB12 THEN + COMMENT ("PREVENTING DEAD VARIABLE OPTIMIZATION"); + END IF; + END; + EXCEPTION + WHEN CONSTRAINT_ERROR => + NULL; + WHEN OTHERS => + FAILED ( "WRONG EXCEPTION RAISED FOR INITIALIZATION " & + "OF VARIABLE 'R10'" ); + END; + + BEGIN + DECLARE + SUBTYPE SRECB IS + RECB (IDENT_INT (-1), IDENT_INT (-2)); + R11 : CONSTANT SRECB := RB12; + BEGIN + FAILED ( "NO EXCEPTION RAISED FOR INITIALIZATION " & + "OF CONSTANT 'R11'" ); + IF R11 = RB12 THEN + COMMENT ("PREVENTING DEAD VARIABLE OPTIMIZATION"); + END IF; + END; + EXCEPTION + WHEN CONSTRAINT_ERROR => + NULL; + WHEN OTHERS => + FAILED ( "WRONG EXCEPTION RAISED FOR INITIALIZATION " & + "OF CONSTANT 'R11'" ); + END; + + BEGIN + DECLARE + SUBTYPE SRECB IS RECB (IDENT_INT (2), IDENT_INT (1)); + R12 : SRECB := RB12; + BEGIN + FAILED ( "NO EXCEPTION RAISED FOR INITIALIZATION " & + "OF VARIABLE 'R12'" ); + IF R12 = RB12 THEN + COMMENT ("PREVENTING DEAD VARIABLE OPTIMIZATION"); + END IF; + END; + EXCEPTION + WHEN CONSTRAINT_ERROR => + NULL; + WHEN OTHERS => + FAILED ( "WRONG EXCEPTION RAISED FOR INITIALIZATION " & + "OF VARIABLE 'R12'" ); + END; + + RESULT; +END C32113A; diff --git a/gcc-4.9/gcc/testsuite/ada/acats/tests/c3/c32115a.ada b/gcc-4.9/gcc/testsuite/ada/acats/tests/c3/c32115a.ada new file mode 100644 index 000000000..826bd2434 --- /dev/null +++ b/gcc-4.9/gcc/testsuite/ada/acats/tests/c3/c32115a.ada @@ -0,0 +1,338 @@ +-- C32115A.ADA + +-- Grant of Unlimited Rights +-- +-- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687, +-- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained +-- unlimited rights in the software and documentation contained herein. +-- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making +-- this public release, the Government intends to confer upon all +-- recipients unlimited rights equal to those held by the Government. +-- These rights include rights to use, duplicate, release or disclose the +-- released technical data and computer software in whole or in part, in +-- any manner and for any purpose whatsoever, and to have or permit others +-- to do so. +-- +-- DISCLAIMER +-- +-- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR +-- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED +-- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE +-- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE +-- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A +-- PARTICULAR PURPOSE OF SAID MATERIAL. +--* +-- OBJECTIVE: +-- CHECK THAT WHEN A VARIABLE OR CONSTANT HAVING A CONSTRAINED +-- ACCESS TYPE IS DECLARED WITH AN INITIAL NON-NULL ACCESS VALUE, +-- CONSTRAINT_ERROR IS RAISED IF AN INDEX BOUND OR A DISCRIMINANT +-- VALUE OF THE DESIGNATED OBJECT DOES NOT EQUAL THE CORRESPONDING +-- VALUE SPECIFIED FOR THE ACCESS SUBTYPE. + +-- HISTORY: +-- RJW 07/20/86 CREATED ORIGINAL TEST. +-- JET 08/05/87 ADDED DEFEAT OF DEAD VARIABLE OPTIMIZATION. +-- PWN 11/30/94 REMOVED TEST ILLEGAL IN ADA 9X. + +WITH REPORT; USE REPORT; + +PROCEDURE C32115A IS + + PACKAGE PKG IS + TYPE PRIV (D : INTEGER) IS PRIVATE; + + PRIVATE + TYPE PRIV (D : INTEGER) IS + RECORD + NULL; + END RECORD; + END PKG; + + USE PKG; + + TYPE ACCP IS ACCESS PRIV (IDENT_INT (1)); + + TYPE REC (D : INTEGER) IS + RECORD + NULL; + END RECORD; + + TYPE ACCR IS ACCESS REC (IDENT_INT (2)); + + TYPE ARR IS ARRAY (NATURAL RANGE <>) OF INTEGER; + + TYPE ACCA IS ACCESS ARR (IDENT_INT (1) .. IDENT_INT (2)); + + TYPE ACCN IS ACCESS ARR (IDENT_INT (1) .. IDENT_INT (0)); + +BEGIN + TEST ("C32115A", "CHECK THAT WHEN A VARIABLE OR CONSTANT " & + "HAVING A CONSTRAINED ACCESS TYPE IS " & + "DECLARED WITH AN INITIAL NON-NULL ACCESS " & + "VALUE, CONSTRAINT_ERROR IS RAISED IF AN " & + "INDEX BOUND OR A DISCRIMINANT VALUE OF THE " & + "DESIGNATED OBJECT DOES NOT EQUAL THE " & + "CORRESPONDING VALUE SPECIFIED FOR THE " & + "ACCESS SUBTYPE" ); + + BEGIN + DECLARE + AC1 : CONSTANT ACCP := NEW PRIV (D => (IDENT_INT (2))); + BEGIN + FAILED ( "NO EXCEPTION RAISED FOR INITIALIZATION " & + "OF CONSTANT 'AC1'" ); + IF AC1 /= NULL THEN + COMMENT ("DEFEAT 'AC1' OPTIMIZATION"); + END IF; + END; + EXCEPTION + WHEN CONSTRAINT_ERROR => + NULL; + WHEN OTHERS => + FAILED ( "WRONG EXCEPTION RAISED FOR INITIALIZATION " & + "OF CONSTANT 'AC1'" ); + END; + + BEGIN + DECLARE + AC2 : ACCP := NEW PRIV (D => (IDENT_INT (2))); + BEGIN + FAILED ( "NO EXCEPTION RAISED FOR INITIALIZATION " & + "OF VARIABLE 'AC2'" ); + IF AC2 /= NULL THEN + COMMENT ("DEFEAT 'AC2' OPTIMIZATION"); + END IF; + END; + EXCEPTION + WHEN CONSTRAINT_ERROR => + NULL; + WHEN OTHERS => + FAILED ( "WRONG EXCEPTION RAISED FOR INITIALIZATION " & + "OF VARIABLE 'AC2'" ); + END; + + BEGIN + DECLARE + AC3 : CONSTANT ACCP := NEW PRIV (D => (IDENT_INT (0))); + BEGIN + FAILED ( "NO EXCEPTION RAISED FOR INITIALIZATION " & + "OF CONSTANT 'AC3'" ); + IF AC3 /= NULL THEN + COMMENT ("DEFEAT 'AC3' OPTIMIZATION"); + END IF; + END; + EXCEPTION + WHEN CONSTRAINT_ERROR => + NULL; + WHEN OTHERS => + FAILED ( "WRONG EXCEPTION RAISED FOR INITIALIZATION " & + "OF CONSTANT 'AC3'" ); + END; + + BEGIN + DECLARE + AC4 : ACCP := NEW PRIV (D => (IDENT_INT (0))); + BEGIN + FAILED ( "NO EXCEPTION RAISED FOR INITIALIZATION " & + "OF VARIABLE 'AC4'" ); + IF AC4 /= NULL THEN + COMMENT ("DEFEAT 'AC4' OPTIMIZATION"); + END IF; + END; + EXCEPTION + WHEN CONSTRAINT_ERROR => + NULL; + WHEN OTHERS => + FAILED ( "WRONG EXCEPTION RAISED FOR INITIALIZATION " & + "OF VARIABLE 'AC4'" ); + END; + + BEGIN + DECLARE + AC5 : CONSTANT ACCR := NEW REC'(D => (IDENT_INT (1))); + BEGIN + FAILED ( "NO EXCEPTION RAISED FOR INITIALIZATION " & + "OF CONSTANT 'AC5'" ); + IF AC5 /= NULL THEN + COMMENT ("DEFEAT 'AC5' OPTIMIZATION"); + END IF; + END; + EXCEPTION + WHEN CONSTRAINT_ERROR => + NULL; + WHEN OTHERS => + FAILED ( "WRONG EXCEPTION RAISED FOR INITIALIZATION " & + "OF CONSTANT 'AC5'" ); + END; + + BEGIN + DECLARE + AC6 : ACCR := NEW REC' (D => (IDENT_INT (1))); + BEGIN + FAILED ( "NO EXCEPTION RAISED FOR INITIALIZATION " & + "OF VARIABLE 'AC6'" ); + IF AC6 /= NULL THEN + COMMENT ("DEFEAT 'AC6' OPTIMIZATION"); + END IF; + END; + EXCEPTION + WHEN CONSTRAINT_ERROR => + NULL; + WHEN OTHERS => + FAILED ( "WRONG EXCEPTION RAISED FOR INITIALIZATION " & + "OF VARIABLE 'AC6'" ); + END; + + BEGIN + DECLARE + AC7 : CONSTANT ACCR := NEW REC'(D => (IDENT_INT (3))); + BEGIN + FAILED ( "NO EXCEPTION RAISED FOR INITIALIZATION " & + "OF CONSTANT 'AC7'" ); + IF AC7 /= NULL THEN + COMMENT ("DEFEAT 'AC7' OPTIMIZATION"); + END IF; + END; + EXCEPTION + WHEN CONSTRAINT_ERROR => + NULL; + WHEN OTHERS => + FAILED ( "WRONG EXCEPTION RAISED FOR INITIALIZATION " & + "OF CONSTANT 'AC7'" ); + END; + + BEGIN + DECLARE + AC8 : ACCR := NEW REC' (D => (IDENT_INT (3))); + BEGIN + FAILED ( "NO EXCEPTION RAISED FOR INITIALIZATION " & + "OF VARIABLE 'AC8'" ); + IF AC8 /= NULL THEN + COMMENT ("DEFEAT 'AC8' OPTIMIZATION"); + END IF; + END; + EXCEPTION + WHEN CONSTRAINT_ERROR => + NULL; + WHEN OTHERS => + FAILED ( "WRONG EXCEPTION RAISED FOR INITIALIZATION " & + "OF VARIABLE 'AC8'" ); + END; + + BEGIN + DECLARE + AC9 : CONSTANT ACCA := + NEW ARR'(IDENT_INT (1) .. IDENT_INT (1) => 0); + BEGIN + FAILED ( "NO EXCEPTION RAISED FOR INITIALIZATION " & + "OF CONSTANT 'AC9'" ); + IF AC9 /= NULL THEN + COMMENT ("DEFEAT 'AC9' OPTIMIZATION"); + END IF; + END; + EXCEPTION + WHEN CONSTRAINT_ERROR => + NULL; + WHEN OTHERS => + FAILED ( "WRONG EXCEPTION RAISED FOR INITIALIZATION " & + "OF CONSTANT 'AC9'" ); + END; + + BEGIN + DECLARE + AC10 : ACCA := + NEW ARR'(IDENT_INT (1) .. IDENT_INT (1) => 0); + BEGIN + FAILED ( "NO EXCEPTION RAISED FOR INITIALIZATION " & + "OF VARIABLE 'AC10'" ); + IF AC10 /= NULL THEN + COMMENT ("DEFEAT 'AC10' OPTIMIZATION"); + END IF; + END; + EXCEPTION + WHEN CONSTRAINT_ERROR => + NULL; + WHEN OTHERS => + FAILED ( "WRONG EXCEPTION RAISED FOR INITIALIZATION " & + "OF VARIABLE 'AC10'" ); + END; + + BEGIN + DECLARE + AC11 : CONSTANT ACCA := + NEW ARR' (IDENT_INT (0) .. IDENT_INT (2) => 0); + BEGIN + FAILED ( "NO EXCEPTION RAISED FOR INITIALIZATION " & + "OF CONSTANT 'AC11'" ); + IF AC11 /= NULL THEN + COMMENT ("DEFEAT 'AC11' OPTIMIZATION"); + END IF; + END; + EXCEPTION + WHEN CONSTRAINT_ERROR => + NULL; + WHEN OTHERS => + FAILED ( "WRONG EXCEPTION RAISED FOR INITIALIZATION " & + "OF CONSTANT 'AC11'" ); + END; + + BEGIN + DECLARE + AC12 : ACCA := + NEW ARR'(IDENT_INT (0) .. IDENT_INT (2) => 0); + BEGIN + FAILED ( "NO EXCEPTION RAISED FOR INITIALIZATION " & + "OF VARIABLE 'AC12'" ); + IF AC12 /= NULL THEN + COMMENT ("DEFEAT 'AC12' OPTIMIZATION"); + END IF; + END; + EXCEPTION + WHEN CONSTRAINT_ERROR => + NULL; + WHEN OTHERS => + FAILED ( "WRONG EXCEPTION RAISED FOR INITIALIZATION " & + "OF VARIABLE 'AC12'" ); + END; + + + BEGIN + DECLARE + AC15 : CONSTANT ACCN := + NEW ARR' (IDENT_INT (0) .. IDENT_INT (0) => 0); + BEGIN + FAILED ( "NO EXCEPTION RAISED FOR INITIALIZATION " & + "OF CONSTANT 'AC15'" ); + IF AC15 /= NULL THEN + COMMENT ("DEFEAT 'AC15' OPTIMIZATION"); + END IF; + END; + EXCEPTION + WHEN CONSTRAINT_ERROR => + NULL; + WHEN OTHERS => + FAILED ( "WRONG EXCEPTION RAISED FOR INITIALIZATION " & + "OF CONSTANT 'AC15'" ); + END; + + BEGIN + DECLARE + AC16 : ACCN := + NEW ARR'(IDENT_INT (0) .. IDENT_INT (0) => 0); + BEGIN + FAILED ( "NO EXCEPTION RAISED FOR INITIALIZATION " & + "OF VARIABLE 'AC16'" ); + IF AC16 /= NULL THEN + COMMENT ("DEFEAT 'AC16' OPTIMIZATION"); + END IF; + END; + EXCEPTION + WHEN CONSTRAINT_ERROR => + NULL; + WHEN OTHERS => + FAILED ( "WRONG EXCEPTION RAISED FOR INITIALIZATION " & + "OF VARIABLE 'AC16'" ); + END; + + RESULT; +END C32115A; diff --git a/gcc-4.9/gcc/testsuite/ada/acats/tests/c3/c32115b.ada b/gcc-4.9/gcc/testsuite/ada/acats/tests/c3/c32115b.ada new file mode 100644 index 000000000..d1819c569 --- /dev/null +++ b/gcc-4.9/gcc/testsuite/ada/acats/tests/c3/c32115b.ada @@ -0,0 +1,376 @@ +-- C32115B.ADA + +-- Grant of Unlimited Rights +-- +-- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687, +-- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained +-- unlimited rights in the software and documentation contained herein. +-- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making +-- this public release, the Government intends to confer upon all +-- recipients unlimited rights equal to those held by the Government. +-- These rights include rights to use, duplicate, release or disclose the +-- released technical data and computer software in whole or in part, in +-- any manner and for any purpose whatsoever, and to have or permit others +-- to do so. +-- +-- DISCLAIMER +-- +-- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR +-- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED +-- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE +-- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE +-- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A +-- PARTICULAR PURPOSE OF SAID MATERIAL. +--* +-- OBJECTIVE: +-- CHECK THAT WHEN A VARIABLE OR CONSTANT HAVING AN UNCONSTRAINED +-- ACCESS TYPE IS DECLARED WITH AN INITIAL NON-NULL ACCESS VALUE, +-- CONSTRAINT_ERROR IS RAISED IF AN INDEX BOUND OR A DISCRIMINANT +-- VALUE OF THE DESIGNATED OBJECT DOES NOT EQUAL THE CORRESPONDING +-- VALUE SPECIFIED FOR THE ACCESS SUBTYPE OF THE OBJECT. + +-- HISTORY: +-- JET 08/05/87 CREATED ORIGINAL TEST BASED ON C32115A BY RJW +-- BUT WITH UNCONSTRAINED ACCESS TYPES AND +-- CONSTRAINED VARIABLE/CONSTANT DECLARATIONS. +-- KAS 12/4/95 FIXED TYPO IN CALL TO REPORT.TEST + +WITH REPORT; USE REPORT; + +PROCEDURE C32115B IS + + PACKAGE PKG IS + TYPE PRIV (D : INTEGER) IS PRIVATE; + + PRIVATE + TYPE PRIV (D : INTEGER) IS + RECORD + NULL; + END RECORD; + END PKG; + + USE PKG; + + TYPE ACCP IS ACCESS PRIV; + + TYPE REC (D : INTEGER) IS + RECORD + NULL; + END RECORD; + + TYPE ACCR IS ACCESS REC; + + TYPE ARR IS ARRAY (NATURAL RANGE <>) OF INTEGER; + + TYPE ACCA IS ACCESS ARR; + + TYPE ACCN IS ACCESS ARR; + +BEGIN + TEST ("C32115B", "CHECK THAT WHEN CONSTRAINED VARIABLE OR " & + "CONSTANT HAVING AN UNCONSTRAINED ACCESS TYPE " & + "IS DECLARED WITH AN INITIAL NON-NULL ACCESS " & + "VALUE, CONSTRAINT_ERROR IS RAISED IF AN " & + "INDEX BOUND OR A DISCRIMINANT VALUE OF THE " & + "DESIGNATED OBJECT DOES NOT EQUAL THE " & + "CORRESPONDING VALUE SPECIFIED FOR THE " & + "ACCESS SUBTYPE OF THE OBJECT" ); + + BEGIN + DECLARE + AC1 : CONSTANT ACCP(1) := NEW PRIV (IDENT_INT (2)); + BEGIN + FAILED ( "NO EXCEPTION RAISED FOR INITIALIZATION " & + "OF CONSTANT 'AC1'" ); + IF AC1 /= NULL THEN + COMMENT ("DEFEAT 'AC1' OPTIMIZATION"); + END IF; + END; + EXCEPTION + WHEN CONSTRAINT_ERROR => + NULL; + WHEN OTHERS => + FAILED ( "WRONG EXCEPTION RAISED FOR INITIALIZATION " & + "OF CONSTANT 'AC1'" ); + END; + + BEGIN + DECLARE + AC2 : ACCP(1) := NEW PRIV (IDENT_INT (2)); + BEGIN + FAILED ( "NO EXCEPTION RAISED FOR INITIALIZATION " & + "OF VARIABLE 'AC2'" ); + IF AC2 /= NULL THEN + COMMENT ("DEFEAT 'AC2' OPTIMIZATION"); + END IF; + END; + EXCEPTION + WHEN CONSTRAINT_ERROR => + NULL; + WHEN OTHERS => + FAILED ( "WRONG EXCEPTION RAISED FOR INITIALIZATION " & + "OF VARIABLE 'AC2'" ); + END; + + BEGIN + DECLARE + AC3 : CONSTANT ACCP(1) := NEW PRIV (IDENT_INT (0)); + BEGIN + FAILED ( "NO EXCEPTION RAISED FOR INITIALIZATION " & + "OF CONSTANT 'AC3'" ); + IF AC3 /= NULL THEN + COMMENT ("DEFEAT 'AC3' OPTIMIZATION"); + END IF; + END; + EXCEPTION + WHEN CONSTRAINT_ERROR => + NULL; + WHEN OTHERS => + FAILED ( "WRONG EXCEPTION RAISED FOR INITIALIZATION " & + "OF CONSTANT 'AC3'" ); + END; + + BEGIN + DECLARE + AC4 : ACCP(1) := NEW PRIV (IDENT_INT (0)); + BEGIN + FAILED ( "NO EXCEPTION RAISED FOR INITIALIZATION " & + "OF VARIABLE 'AC4'" ); + IF AC4 /= NULL THEN + COMMENT ("DEFEAT 'AC4' OPTIMIZATION"); + END IF; + END; + EXCEPTION + WHEN CONSTRAINT_ERROR => + NULL; + WHEN OTHERS => + FAILED ( "WRONG EXCEPTION RAISED FOR INITIALIZATION " & + "OF VARIABLE 'AC4'" ); + END; + + BEGIN + DECLARE + AC5 : CONSTANT ACCR(2) := NEW REC(IDENT_INT (1)); + BEGIN + FAILED ( "NO EXCEPTION RAISED FOR INITIALIZATION " & + "OF CONSTANT 'AC5'" ); + IF AC5 /= NULL THEN + COMMENT ("DEFEAT 'AC5' OPTIMIZATION"); + END IF; + END; + EXCEPTION + WHEN CONSTRAINT_ERROR => + NULL; + WHEN OTHERS => + FAILED ( "WRONG EXCEPTION RAISED FOR INITIALIZATION " & + "OF CONSTANT 'AC5'" ); + END; + + BEGIN + DECLARE + AC6 : ACCR(2) := NEW REC (IDENT_INT (1)); + BEGIN + FAILED ( "NO EXCEPTION RAISED FOR INITIALIZATION " & + "OF VARIABLE 'AC6'" ); + IF AC6 /= NULL THEN + COMMENT ("DEFEAT 'AC6' OPTIMIZATION"); + END IF; + END; + EXCEPTION + WHEN CONSTRAINT_ERROR => + NULL; + WHEN OTHERS => + FAILED ( "WRONG EXCEPTION RAISED FOR INITIALIZATION " & + "OF VARIABLE 'AC6'" ); + END; + + BEGIN + DECLARE + AC7 : CONSTANT ACCR(2) := NEW REC(IDENT_INT (3)); + BEGIN + FAILED ( "NO EXCEPTION RAISED FOR INITIALIZATION " & + "OF CONSTANT 'AC7'" ); + IF AC7 /= NULL THEN + COMMENT ("DEFEAT 'AC7' OPTIMIZATION"); + END IF; + END; + EXCEPTION + WHEN CONSTRAINT_ERROR => + NULL; + WHEN OTHERS => + FAILED ( "WRONG EXCEPTION RAISED FOR INITIALIZATION " & + "OF CONSTANT 'AC7'" ); + END; + + BEGIN + DECLARE + AC8 : ACCR(2) := NEW REC (IDENT_INT (3)); + BEGIN + FAILED ( "NO EXCEPTION RAISED FOR INITIALIZATION " & + "OF VARIABLE 'AC8'" ); + IF AC8 /= NULL THEN + COMMENT ("DEFEAT 'AC8' OPTIMIZATION"); + END IF; + END; + EXCEPTION + WHEN CONSTRAINT_ERROR => + NULL; + WHEN OTHERS => + FAILED ( "WRONG EXCEPTION RAISED FOR INITIALIZATION " & + "OF VARIABLE 'AC8'" ); + END; + + BEGIN + DECLARE + AC9 : CONSTANT ACCA(1 .. 2) := + NEW ARR(IDENT_INT(1) .. IDENT_INT (1)); + BEGIN + FAILED ( "NO EXCEPTION RAISED FOR INITIALIZATION " & + "OF CONSTANT 'AC9'" ); + IF AC9 /= NULL THEN + COMMENT ("DEFEAT 'AC9' OPTIMIZATION"); + END IF; + END; + EXCEPTION + WHEN CONSTRAINT_ERROR => + NULL; + WHEN OTHERS => + FAILED ( "WRONG EXCEPTION RAISED FOR INITIALIZATION " & + "OF CONSTANT 'AC9'" ); + END; + + BEGIN + DECLARE + AC10 : ACCA (1..2) := + NEW ARR(IDENT_INT (1) .. IDENT_INT (1)); + BEGIN + FAILED ( "NO EXCEPTION RAISED FOR INITIALIZATION " & + "OF VARIABLE 'AC10'" ); + IF AC10 /= NULL THEN + COMMENT ("DEFEAT 'AC10' OPTIMIZATION"); + END IF; + END; + EXCEPTION + WHEN CONSTRAINT_ERROR => + NULL; + WHEN OTHERS => + FAILED ( "WRONG EXCEPTION RAISED FOR INITIALIZATION " & + "OF VARIABLE 'AC10'" ); + END; + + BEGIN + DECLARE + AC11 : CONSTANT ACCA(1..2) := + NEW ARR(IDENT_INT (0) .. IDENT_INT (2)); + BEGIN + FAILED ( "NO EXCEPTION RAISED FOR INITIALIZATION " & + "OF CONSTANT 'AC11'" ); + IF AC11 /= NULL THEN + COMMENT ("DEFEAT 'AC11' OPTIMIZATION"); + END IF; + END; + EXCEPTION + WHEN CONSTRAINT_ERROR => + NULL; + WHEN OTHERS => + FAILED ( "WRONG EXCEPTION RAISED FOR INITIALIZATION " & + "OF CONSTANT 'AC11'" ); + END; + + BEGIN + DECLARE + AC12 : ACCA(1..2) := + NEW ARR(IDENT_INT (0) .. IDENT_INT (2)); + BEGIN + FAILED ( "NO EXCEPTION RAISED FOR INITIALIZATION " & + "OF VARIABLE 'AC12'" ); + IF AC12 /= NULL THEN + COMMENT ("DEFEAT 'AC12' OPTIMIZATION"); + END IF; + END; + EXCEPTION + WHEN CONSTRAINT_ERROR => + NULL; + WHEN OTHERS => + FAILED ( "WRONG EXCEPTION RAISED FOR INITIALIZATION " & + "OF VARIABLE 'AC12'" ); + END; + + BEGIN + DECLARE + AC13 : CONSTANT ACCA (1..2) := + NEW ARR(IDENT_INT (2) .. IDENT_INT (3)); + BEGIN + FAILED ( "NO EXCEPTION RAISED FOR INITIALIZATION " & + "OF CONSTANT 'AC13'" ); + IF AC13 /= NULL THEN + COMMENT ("DEFEAT 'AC13' OPTIMIZATION"); + END IF; + END; + EXCEPTION + WHEN CONSTRAINT_ERROR => + NULL; + WHEN OTHERS => + FAILED ( "WRONG EXCEPTION RAISED FOR INITIALIZATION " & + "OF CONSTANT 'AC13'" ); + END; + + BEGIN + DECLARE + AC14 : ACCA(1..2) := + NEW ARR(IDENT_INT (2) .. IDENT_INT (3)); + BEGIN + FAILED ( "NO EXCEPTION RAISED FOR INITIALIZATION " & + "OF VARIABLE 'AC14'" ); + IF AC14 /= NULL THEN + COMMENT ("DEFEAT 'AC14' OPTIMIZATION"); + END IF; + END; + EXCEPTION + WHEN CONSTRAINT_ERROR => + NULL; + WHEN OTHERS => + FAILED ( "WRONG EXCEPTION RAISED FOR INITIALIZATION " & + "OF VARIABLE 'AC14'" ); + END; + + BEGIN + DECLARE + AC15 : CONSTANT ACCN(1..0) := + NEW ARR(IDENT_INT (0) .. IDENT_INT (0)); + BEGIN + FAILED ( "NO EXCEPTION RAISED FOR INITIALIZATION " & + "OF CONSTANT 'AC15'" ); + IF AC15 /= NULL THEN + COMMENT ("DEFEAT 'AC15' OPTIMIZATION"); + END IF; + END; + EXCEPTION + WHEN CONSTRAINT_ERROR => + NULL; + WHEN OTHERS => + FAILED ( "WRONG EXCEPTION RAISED FOR INITIALIZATION " & + "OF CONSTANT 'AC15'" ); + END; + + BEGIN + DECLARE + AC16 : ACCN(1..0) := + NEW ARR(IDENT_INT (0) .. IDENT_INT (0)); + BEGIN + FAILED ( "NO EXCEPTION RAISED FOR INITIALIZATION " & + "OF VARIABLE 'AC16'" ); + IF AC16 /= NULL THEN + COMMENT ("DEFEAT 'AC16' OPTIMIZATION"); + END IF; + END; + EXCEPTION + WHEN CONSTRAINT_ERROR => + NULL; + WHEN OTHERS => + FAILED ( "WRONG EXCEPTION RAISED FOR INITIALIZATION " & + "OF VARIABLE 'AC16'" ); + END; + + RESULT; +END C32115B; diff --git a/gcc-4.9/gcc/testsuite/ada/acats/tests/c3/c330001.a b/gcc-4.9/gcc/testsuite/ada/acats/tests/c3/c330001.a new file mode 100644 index 000000000..218896d67 --- /dev/null +++ b/gcc-4.9/gcc/testsuite/ada/acats/tests/c3/c330001.a @@ -0,0 +1,354 @@ +-- C330001.A +-- +-- Grant of Unlimited Rights +-- +-- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687, +-- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained +-- unlimited rights in the software and documentation contained herein. +-- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making +-- this public release, the Government intends to confer upon all +-- recipients unlimited rights equal to those held by the Government. +-- These rights include rights to use, duplicate, release or disclose the +-- released technical data and computer software in whole or in part, in +-- any manner and for any purpose whatsoever, and to have or permit others +-- to do so. +-- +-- DISCLAIMER +-- +-- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR +-- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED +-- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE +-- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE +-- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A +-- PARTICULAR PURPOSE OF SAID MATERIAL. +--* +-- +-- OBJECTIVE: +-- Check that a variable object of an indefinite type is properly +-- initialized/constrained by an initial value assignment that is +-- a) an aggregate, b) a function, or c) an object. Check that objects +-- of the above types do not need explicit constraints if they have +-- initial values. +-- +-- TEST DESCRIPTION: +-- An indefinite subtype is either: +-- a) An unconstrained array subtype. +-- b) A subtype with unknown discriminants. +-- c) A subtype with unconstrained discriminants without defaults. +-- +-- Declare several indefinite types in a parent package specification. +-- In the private part, complete one type with a discriminant without +-- default (indefinite) and the other with a default discriminant +-- (definite). Declare objects of both indefinite and definite subtypes +-- in children (private and public) with initialization expressions. The +-- test verifies all values of the objects. It also verifies that +-- Constraint_Error is raised if an attempt is made to change the +-- discriminants of the objects of the indefinite subtypes. +-- +-- +-- CHANGE HISTORY: +-- 15 Jan 95 SAIC Initial version for ACVC 2.1 +-- 25 Jul 96 SAIC Modified test description. Deleted use C330001_0. +-- 20 Nov 98 RLB Added Elaborate pragmas to avoid problems +-- with an unconventional, but legal, elaboration +-- order. +--! + +package C330001_0 is + + subtype Sub_Type is Integer range 1 .. 20; + + type Tag_W_Disc (D : Sub_Type) is tagged record + C1 : String (1 .. D); + end record; + + -- Indefinite type declarations. + + type FullViewDefinite_Unknown_Disc (<>) is private; + + type Indefinite_No_Disc is array (Positive range <>) of Integer; + + type Indefinite_Tag_W_Disc (D : Sub_Type) is tagged + record + C1 : Boolean := False; + end record; + + type Indefinite_New_W_Disc (ND : Sub_Type) is new + Indefinite_Tag_W_Disc (ND) with record + C2 : Integer := 9; + end record; + + type Indefinite_W_Inherit_Disc_1 is new Tag_W_Disc with + record + S : Sub_Type := 18; + end record; + + type Indefinite_W_Inherit_Disc_2 is + new Tag_W_Disc with private; + + function Indef_Func_1 return FullViewDefinite_Unknown_Disc; + + function Indef_Func_2 (P : Sub_Type) return Indefinite_W_Inherit_Disc_2; + +private + + type FullViewDefinite_Unknown_Disc (D : Sub_Type := 2) is + record + S : String (1 .. D) := "Hi"; + end record; + + type Indefinite_W_Inherit_Disc_2 is new Tag_W_Disc with + record + S : Sub_Type; + end record; + +end C330001_0; + + --==================================================================-- + +package body C330001_0 is + + function Indef_Func_1 return FullViewDefinite_Unknown_Disc is + Var_1 : FullViewDefinite_Unknown_Disc; -- No need for explicit + -- constraints, use initial + begin -- values. + return Var_1; + end Indef_Func_1; + + ------------------------------------------------------------------ + function Indef_Func_2 (P : Sub_Type) return Indefinite_W_Inherit_Disc_2 is + Var_2 : Indefinite_W_Inherit_Disc_2 := (D => 5, C1 => "Hello", S => P); + begin + return Var_2; + end Indef_Func_2; + +end C330001_0; + + --==================================================================-- + +with C330001_0; +pragma Elaborate(C330001_0); -- Insure that the functions can be called. +private +package C330001_0.C330001_1 is + + PrivateChild_Obj : Tag_W_Disc := (D => 4, C1 => "ACVC"); + + PrivateChild_Obj_01 : Indefinite_W_Inherit_Disc_1 + := Indefinite_W_Inherit_Disc_1'(PrivateChild_Obj with S => 15); + + -- Since full view of Indefinite_W_Inherit_Disc_2 is indefinite in + -- the parent package, Indefinite_W_Inherit_Disc_2 needs an initialization + -- expression. + + PrivateChild_Obj_02 : Indefinite_W_Inherit_Disc_2 := Indef_Func_2 (19); + + -- Since full view of FullViewDefinite_Unknown_Disc is definite in the + -- parent package, no initialization expression needed for + -- PrivateChild_Obj_03. + + PrivateChild_Obj_03 : FullViewDefinite_Unknown_Disc; + + PrivateChild_Obj_04 : Indefinite_No_Disc := (12, 15); + +end C330001_0.C330001_1; + + --==================================================================-- + +with C330001_0; +pragma Elaborate(C330001_0); -- Insure that the functions can be called. +package C330001_0.C330001_2 is + + PublicChild_Obj_01 : FullViewDefinite_Unknown_Disc := Indef_Func_1; + + PublicChild_Obj_02 : Indefinite_W_Inherit_Disc_2 := Indef_Func_2 (4); + + PublicChild_Obj_03 : Indefinite_No_Disc := (38, 72, 21, 59); + + PublicChild_Obj_04 : Indefinite_Tag_W_Disc := (D => 7, C1 => True); + + PublicChild_Obj_05 : Indefinite_Tag_W_Disc := PublicChild_Obj_04; + + PublicChild_Obj_06 : Indefinite_New_W_Disc (6); + + procedure Assign_Private_Obj_3; + + function Raised_CE_PublicChild_Obj return Boolean; + + function Raised_CE_PrivateChild_Obj return Boolean; + + -- The following functions check the private types defined in the parent + -- and the private child package from within the client program. + + function Verify_Public_Obj_1 return Boolean; + + function Verify_Public_Obj_2 return Boolean; + + function Verify_Private_Obj_1 return Boolean; + + function Verify_Private_Obj_2 return Boolean; + + function Verify_Private_Obj_3 return Boolean; + +end C330001_0.C330001_2; + + --==================================================================-- + +with Report; +with C330001_0.C330001_1; +package body C330001_0.C330001_2 is + + procedure Assign_Private_Obj_3 is + begin + C330001_0.C330001_1.PrivateChild_Obj_03 := (5, "Aloha"); + end Assign_Private_Obj_3; + + ------------------------------------------------------------------ + function Raised_CE_PublicChild_Obj return Boolean is + begin + PublicChild_Obj_03 := (16, 13); -- C_E, can't change constraints + -- of PublicChild_Obj_03. + + Report.Failed ("Constraint_Error not raised - Public child"); + + -- Next line prevents dead assignment. + + Report.Comment ("PublicChild_Obj_03'First is" & Integer'Image + (PublicChild_Obj_03'First) ); + return False; + + exception + when Constraint_Error => + return True; -- Exception is expected. + when others => + return False; + end Raised_CE_PublicChild_Obj; + + ------------------------------------------------------------------ + function Raised_CE_PrivateChild_Obj return Boolean is + begin + C330001_0.C330001_1.PrivateChild_Obj_04 := (21, 87, 18); + -- C_E, can't change constraints + -- of PrivateChild_Obj_04. + + Report.Failed ("Constraint_Error not raised - Private child"); + + -- Next line prevents dead assignment. + + Report.Comment ("PrivateChild_Obj_04'Last is" & Integer'Image + (C330001_0.C330001_1.PrivateChild_Obj_04'Last) ); + return False; + + exception + when Constraint_Error => + return True; -- Exception is expected. + when others => + return False; + end Raised_CE_PrivateChild_Obj; + + ------------------------------------------------------------------ + function Verify_Public_Obj_1 return Boolean is + begin + return (PublicChild_Obj_01.D = 2 and PublicChild_Obj_01.S = "Hi"); + + end Verify_Public_Obj_1; + + ------------------------------------------------------------------ + function Verify_Public_Obj_2 return Boolean is + begin + return (PublicChild_Obj_02.D = 5 and + PublicChild_Obj_02.C1 = "Hello" and + PublicChild_Obj_02.S = 4); + + end Verify_Public_Obj_2; + + ------------------------------------------------------------------ + function Verify_Private_Obj_1 return Boolean is + begin + return (C330001_0.C330001_1.PrivateChild_Obj_01.D = 4 and + C330001_0.C330001_1.PrivateChild_Obj_01.C1 = "ACVC" and + C330001_0.C330001_1.PrivateChild_Obj_01.S = 15); + + end Verify_Private_Obj_1; + + ------------------------------------------------------------------ + function Verify_Private_Obj_2 return Boolean is + begin + return (C330001_0.C330001_1.PrivateChild_Obj_02.D = 5 and + C330001_0.C330001_1.PrivateChild_Obj_02.C1 = "Hello" and + C330001_0.C330001_1.PrivateChild_Obj_02.S = 19); + + end Verify_Private_Obj_2; + + ------------------------------------------------------------------ + function Verify_Private_Obj_3 return Boolean is + begin + return (C330001_0.C330001_1.PrivateChild_Obj_03.D = 5 and + C330001_0.C330001_1.PrivateChild_Obj_03.S = "Aloha"); + + end Verify_Private_Obj_3; + +end C330001_0.C330001_2; + + --==================================================================-- + +with C330001_0.C330001_2; +with Report; + +use C330001_0.C330001_2; + +procedure C330001 is +begin + Report.Test ("C330001", "Check that a variable object of an indefinite " & + "type is properly initialized/constrained by an initial " & + "value assignment that is a) an aggregate, b) a function, " & + "or c) an object. Check that objects of the above types " & + "do not need explicit constraints if they have initial " & + "values"); + + -- Verify values of public child objects. + + if not (Verify_Public_Obj_1 and Verify_Public_Obj_2) then + Report.Failed ("Wrong values for PublicChild_Obj_01 or " & + "PublicChild_Obj_02"); + end if; + + if PublicChild_Obj_03'First /= 1 or + PublicChild_Obj_03'Last /= 4 then + Report.Failed ("Wrong values for PublicChild_Obj_03"); + end if; + + if PublicChild_Obj_05.D /= 7 or + not PublicChild_Obj_05.C1 then + Report.Failed ("Wrong values for PublicChild_Obj_05"); + end if; + + if PublicChild_Obj_06.ND /= 6 or + PublicChild_Obj_06.C2 /= 9 or + PublicChild_Obj_06.C1 then + Report.Failed ("Wrong values for PublicChild_Obj_06"); + end if; + + -- Definite object can have its discriminant changed by assignment to + -- the entire object. + + Assign_Private_Obj_3; + + -- Verify values of private child objects. + + if not Verify_Private_Obj_1 or not + Verify_Private_Obj_2 or not + Verify_Private_Obj_3 then + Report.Failed ("Wrong values for PrivateChild_Obj_01 or " & + "PrivateChild_Obj_02 or PrivateChild_Obj_03"); + end if; + + -- Attempt to change the discriminants of the objects of the indefinite + -- subtypes: Constraint_Error. + + if not Raised_CE_PublicChild_Obj or not Raised_CE_PrivateChild_Obj then + Report.Failed ("Constraint_Error not raised"); + end if; + + Report.Result; + +end C330001; diff --git a/gcc-4.9/gcc/testsuite/ada/acats/tests/c3/c330002.a b/gcc-4.9/gcc/testsuite/ada/acats/tests/c3/c330002.a new file mode 100644 index 000000000..1403d5557 --- /dev/null +++ b/gcc-4.9/gcc/testsuite/ada/acats/tests/c3/c330002.a @@ -0,0 +1,326 @@ +-- C330002.A +-- +-- Grant of Unlimited Rights +-- +-- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687, +-- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained +-- unlimited rights in the software and documentation contained herein. +-- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making +-- this public release, the Government intends to confer upon all +-- recipients unlimited rights equal to those held by the Government. +-- These rights include rights to use, duplicate, release or disclose the +-- released technical data and computer software in whole or in part, in +-- any manner and for any purpose whatsoever, and to have or permit others +-- to do so. +-- +-- DISCLAIMER +-- +-- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR +-- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED +-- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE +-- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE +-- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A +-- PARTICULAR PURPOSE OF SAID MATERIAL. +--* +-- +-- OBJECTIVE: +-- Check that if a subtype indication of a variable object defines an +-- indefinite subtype, then there is an initialization expression. +-- Check that the object remains so constrained throughout its lifetime. +-- Check for cases of tagged record, arrays and generic formal type. +-- +-- TEST DESCRIPTION: +-- An indefinite subtype is either: +-- a) An unconstrained array subtype. +-- b) A subtype with unknown discriminants (this includes class-wide +-- types). +-- c) A subtype with unconstrained discriminants without defaults. +-- +-- Declare tagged types with unconstrained discriminants without +-- defaults. Declare an unconstrained array. Declare a generic formal +-- type with an unknown discriminant and a formal object of this type. +-- In the generic package, declare an object of the formal type using +-- the formal object as its initial value. In the main program, +-- declare objects of tagged types. Instantiate the generic package. +-- The test checks that Constraint_Error is raised if an attempt is +-- made to change bounds as well as discriminants of the objects of the +-- indefinite subtypes. +-- +-- +-- CHANGE HISTORY: +-- 01 Nov 95 SAIC Initial prerelease version. +-- 27 Jul 96 SAIC Modified test description & Report.Test. Added +-- code to prevent dead variable optimization. +-- +--! + +package C330002_0 is + + subtype Small_Num is Integer range 1 .. 20; + + -- Types with unconstrained discriminants without defaults. + + type Tag_Type (Disc : Small_Num) is tagged + record + S : String (1 .. Disc); + end record; + + function Tag_Value return Tag_Type; + + procedure Assign_Tag (A : out Tag_Type); + + procedure Avoid_Optimization_and_Fail (P : Tag_Type; Msg : String); + + --------------------------------------------------------------------- + -- An unconstrained array type. + + type Array_Type is array (Positive range <>) of Integer; + + function Array_Value return Array_Type; + + procedure Assign_Array (A : out Array_Type); + + --------------------------------------------------------------------- + generic + -- Type with an unknown discriminant. + type Formal_Type (<>) is private; + FT_Obj : Formal_Type; + package Gen is + Gen_Obj : Formal_Type := FT_Obj; + end Gen; + +end C330002_0; + + --==================================================================-- + +with Report; +package body C330002_0 is + + procedure Assign_Tag (A : out Tag_Type) is + begin + A := (3, "Bye"); + end Assign_Tag; + + ---------------------------------------------------------------------- + procedure Avoid_Optimization_and_Fail (P : Tag_Type; Msg : String) is + Default : Tag_Type := (1, "!"); -- Unique value. + begin + if P = Default then -- Both If branches can't do the same thing. + Report.Failed (Msg & ": Constraint_Error not raised"); + else -- Subtests should always select this path. + Report.Failed ("Constraint_Error not raised " & Msg); + end if; + end Avoid_Optimization_and_Fail; + + ---------------------------------------------------------------------- + function Tag_Value return Tag_Type is + TO : Tag_Type := (4 , "ACVC"); + begin + return TO; + end Tag_Value; + + ---------------------------------------------------------------------- + function Array_Value return Array_Type is + IA : Array_Type := (20, 31); + begin + return IA; + end Array_Value; + + ---------------------------------------------------------------------- + procedure Assign_Array (A : out Array_Type) is + begin + A := (84, 36); + end Assign_Array; + +end C330002_0; + + --==================================================================-- + +with Report; +with C330002_0; +use C330002_0; + +procedure C330002 is + +begin + Report.Test ("C330002", "Check that if a subtype indication of a " & + "variable object defines an indefinite subtype, then " & + "there is an initialization expression. Check that " & + "the object remains so constrained throughout its " & + "lifetime. Check that Constraint_Error is raised " & + "if an attempt is made to change bounds as well as " & + "discriminants of the objects of the indefinite " & + "subtypes. Check for cases of tagged record and generic " & + "formal types"); + + TagObj_Block: + declare + TObj_ByAgg : Tag_Type := (5, "Hello"); -- Initial assignment is + -- aggregate. + TObj_ByObj : Tag_Type := TObj_ByAgg; -- Initial assignment is + -- an object. + TObj_ByFunc : Tag_Type := Tag_Value; -- Initial assignment is + -- function return value. + Ren_Obj : Tag_Type renames TObj_ByAgg; + + begin + + begin + if (TObj_ByAgg.Disc /= 5) or (TObj_ByAgg.S /= "Hello") then + Report.Failed ("Wrong initial values for TObj_ByAgg"); + end if; + + TObj_ByAgg := (2, "Hi"); -- C_E, can't change the + -- value of the discriminant. + + Avoid_Optimization_and_Fail (TObj_ByAgg, "Subtest 1"); + + exception + when Constraint_Error => null; -- Exception is expected. + when others => + Report.Failed ("Unexpected exception - Subtest 1"); + end; + + + begin + Assign_Tag (Ren_Obj); -- C_E, can't change the + -- value of the discriminant. + + Avoid_Optimization_and_Fail (Ren_Obj, "Subtest 2"); + + exception + when Constraint_Error => null; -- Exception is expected. + when others => + Report.Failed ("Unexpected exception - Subtest 2"); + end; + + + begin + if (TObj_ByObj.Disc /= 5) or (TObj_ByObj.S /= "Hello") then + Report.Failed ("Wrong initial values for TObj_ByObj"); + end if; + + TObj_ByObj := (3, "Bye"); -- C_E, can't change the + -- value of the discriminant. + + Avoid_Optimization_and_Fail (TObj_ByObj, "Subtest 3"); + + exception + when Constraint_Error => null; -- Exception is expected. + when others => + Report.Failed ("Unexpected exception - Subtest 3"); + end; + + + begin + if (TObj_ByFunc.Disc /= 4) or (TObj_ByFunc.S /= "ACVC") then + Report.Failed ("Wrong initial values for TObj_ByFunc"); + end if; + + TObj_ByFunc := (5, "Aloha"); -- C_E, can't change the + -- value of the discriminant. + + Avoid_Optimization_and_Fail (TObj_ByFunc, "Subtest 4"); + + exception + when Constraint_Error => null; -- Exception is expected. + when others => + Report.Failed ("Unexpected exception - Subtest 4"); + end; + + end TagObj_Block; + + + ArrObj_Block: + declare + Arr_Const : constant Array_Type + := (9, 7, 6, 8); + Arr_ByAgg : Array_Type -- Initial assignment is + := (10, 11, 12); -- aggregate. + Arr_ByFunc : Array_Type -- Initial assignment is + := Array_Value; -- function return value. + Arr_ByObj : Array_Type -- Initial assignment is + := Arr_ByAgg; -- object. + + Arr_Obj : array (Positive range <>) of Integer + := (1, 2, 3, 4, 5); + begin + + begin + if (Arr_Const'First /= 1) or (Arr_Const'Last /= 4) then + Report.Failed ("Wrong bounds for Arr_Const"); + end if; + + if (Arr_ByAgg'First /= 1) or (Arr_ByAgg'Last /= 3) then + Report.Failed ("Wrong bounds for Arr_ByAgg"); + end if; + + if (Arr_ByFunc'First /= 1) or (Arr_ByFunc'Last /= 2) then + Report.Failed ("Wrong bounds for Arr_ByFunc"); + end if; + + if (Arr_ByObj'First /= 1) or (Arr_ByObj'Last /= 3) then + Report.Failed ("Wrong bounds for Arr_ByObj"); + end if; + + Assign_Array (Arr_ByObj); -- C_E, Arr_ByObj bounds are + -- 1..3. + + Report.Failed ("Constraint_Error not raised - Subtest 5"); + + exception + when Constraint_Error => null; -- Exception is expected. + when others => + Report.Failed ("Unexpected exception - Subtest 5"); + end; + + + begin + if (Arr_Obj'First /= 1) or (Arr_Obj'Last /= 5) then + Report.Failed ("Wrong bounds for Arr_Obj"); + end if; + + for I in 0 .. 5 loop + Arr_Obj (I + 1) := I + 5; -- C_E, Arr_Obj bounds are + end loop; -- 1..5. + + Report.Failed ("Constraint_Error not raised - Subtest 6"); + + exception + when Constraint_Error => null; -- Exception is expected. + when others => + Report.Failed ("Unexpected exception - Subtest 6"); + end; + + end ArrObj_Block; + + + GenericObj_Block: + declare + type Rec (Disc : Small_Num) is + record + S : Small_Num := Disc; + end record; + + Rec_Obj : Rec := (2, 2); + package IGen is new Gen (Rec, Rec_Obj); + + begin + IGen.Gen_Obj := (3, 3); -- C_E, can't change the + -- value of the discriminant. + + Report.Failed ("Constraint_Error not raised - Subtest 7"); + + -- Next line prevents dead assignment. + Report.Comment ("Disc is" & Integer'Image (IGen.Gen_Obj.Disc)); + + exception + when Constraint_Error => null; -- Exception is expected. + when others => + Report.Failed ("Unexpected exception - Subtest 7"); + + end GenericObj_Block; + + Report.Result; + +end C330002; diff --git a/gcc-4.9/gcc/testsuite/ada/acats/tests/c3/c332001.a b/gcc-4.9/gcc/testsuite/ada/acats/tests/c3/c332001.a new file mode 100644 index 000000000..21d657373 --- /dev/null +++ b/gcc-4.9/gcc/testsuite/ada/acats/tests/c3/c332001.a @@ -0,0 +1,226 @@ +-- C332001.A +-- +-- Grant of Unlimited Rights +-- +-- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687, +-- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained +-- unlimited rights in the software and documentation contained herein. +-- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making +-- this public release, the Government intends to confer upon all +-- recipients unlimited rights equal to those held by the Government. +-- These rights include rights to use, duplicate, release or disclose the +-- released technical data and computer software in whole or in part, in +-- any manner and for any purpose whatsoever, and to have or permit others +-- to do so. +-- +-- DISCLAIMER +-- +-- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR +-- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED +-- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE +-- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE +-- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A +-- PARTICULAR PURPOSE OF SAID MATERIAL. +--* +-- +-- OBJECTIVE: +-- Check that the static expression given for a number declaration may be +-- of any numeric type. Check that the type of a named number is +-- universal_integer or universal_real regardless of the type of the +-- static expression that provides its value. +-- +-- TEST DESCRIPTION: +-- This test defines a large cross section of mixed type named numbers. +-- Well, obviously the named numbers don't have types (other than +-- universal_integer and universal_real) associated with them. +-- This test uses typed static values in the definition of several named +-- numbers, and then mixes the named numbers to ensure that their typed +-- origins do not interfere with the use of their values. +-- +-- +-- CHANGE HISTORY: +-- 10 OCT 95 SAIC Initial version +-- 11 APR 96 SAIC Fixed a few arithmetic errors for 2.1 +-- 24 NOV 98 RLB Removed decimal types to insure that this +-- test is applicable to all implementations. +-- +--! + +----------------------------------------------------------------- C332001_0 + +package C332001_0 is + + type Enumeration_Type is ( Ah, Gnome, Er, Ay, Shun ); + + type Integer_Type is range 0..1023; + + type Modular_Type is mod 256; + + type Floating_Type is digits 4; + + type Fixed_Type is delta 0.125 range -10.0 .. 10.0; + + type Mod_Array is array(Modular_Type) of Floating_Type; + + type Int_Array is array(Integer_Type) of Fixed_Type; + + type Record_Type is record + Pinkie : Integer_Type; + Ring : Modular_Type; + Middle : Floating_Type; + Index : Fixed_Type; + end record; + + Mod_Array_Object : Mod_Array; + Int_Array_Object : Int_Array; + + Record_Object : Record_Type; + + -- numeric_literals + + Nothing_New_Integer : constant := 1; + Nothing_New_Real : constant := 1.0; + + -- static constants + + Integ : constant Integer_Type := 2; + Modul : constant Modular_Type := 2; + Float : constant Floating_Type := 2.0; -- bad practice, good test + Fixed : constant Fixed_Type := 2.0; + + Named_Integer : constant := Integ; -- 2 + Named_Modular : constant := Modul; -- 2 + Named_Float : constant := Float; -- 2.0 + Named_Fixed : constant := Fixed; -- 2.0 + + -- function calls + -- parenthetical expressions + + Fn_Integer : constant := Integer_Type'Min(Integ * 2, 8); -- 4 + Fn_Modular : constant := Modular_Type'Max(Modul + 2, Modular_Type'First);--4 + Fn_Float : constant := (Float ** 2); -- 4.0 + Fn_Fixed : constant := - Fixed; -- -2.0 + -- attributes + + ITF : constant := Integer_Type'First; -- 0 + MTL : constant := Modular_Type'Last; -- 255 + MTM : constant := Modular_Type'Modulus; -- 256 + ENP : constant := Enumeration_Type'Pos(Ay); -- 3 + MTP : constant := Modular_Type'Pred(Modul); -- 1 + FTS : constant := Fixed_Type'Size; -- # impdef + ITS : constant := Integer_Type'Succ(Integ); -- 3 + + -- array attributes 'First, 'Last, 'Length + + MAFirst : constant := Mod_Array_Object'First; -- 0 + IALast : constant := Int_Array_Object'Last; -- 1023 + MAL : constant := Mod_Array_Object'Length; -- 255 + IAL : constant := Int_Array_Object'Length; -- 1024 + + -- type conversions + -- + -- F\T Int Mod Flt Fix + -- Int . X O X + -- Mod O . X O + -- Flt X O . X + -- Fix O X O . + + Int2Mod : constant := Modular_Type (Integ); -- 2 + Int2Fix : constant := Fixed_Type (Integ); -- 2.0 + Mod2Flt : constant := Floating_Type (Modul); -- 2.0 + Flt2Int : constant := Integer_Type(Float); -- 2 + Flt2Fix : constant := Fixed_Type (Float); -- 2.0 + Fix2Mod : constant := Modular_Type (Fixed); -- 2 + + procedure Check_Values; + + -- TRANSITION CHECKS + -- + -- The following were illegal in Ada83; they are now legal in Ada95 + -- + + Int_Base_First : constant := Integer'Base'First; -- # impdef + Int_First : constant := Integer'First; -- # impdef + Int_Last : constant := Integer'Last; -- # impdef + Int_Val : constant := Integer'Val(17); -- 17 + + -- END OF TRANSITION CHECKS + +end C332001_0; + +-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- + +with Report; +package body C332001_0 is + + procedure Assert( Truth : Boolean; Message: String ) is + begin + if not Truth then + Report.Failed("Assertion " & Message & " not true" ); + end if; + end Assert; + + procedure Check_Values is + begin + + Assert( Nothing_New_Integer * Named_Integer = Named_Modular, + "Nothing_New_Integer * Named_Integer = Named_Modular" ); -- 1*2 = 2 + Assert( Nothing_New_Real * Named_Float = Named_Fixed, + "Nothing_New_Real * Named_Float = Named_Fixed" );-- 1.0*2.0 = 2.0 + + Assert( Fn_Integer = Int2Mod + Flt2Int, + "Fn_Integer = Int2Mod + Flt2Int" ); -- 4 = 2+2 + Assert( Fn_Modular = Flt2Int * 2, + "Fn_Modular = Flt2Int * 2" ); -- 4 = 2*2 + Assert( Fn_Float = Mod2Flt ** Fix2Mod, + "Fn_Float = Mod2Flt ** Fix2Mod" ); -- 4.0 = 2.0**2 + Assert( Fn_Fixed = (- Mod2Flt), + "Fn_Fixed = (- Mod2Flt)" ); -- -2.0 = (-2.0) + + Assert( ITF = Modular_Type'First, + "ITF = Modular_Type'First" ); -- 0 = 0 + Assert( MTL < Integer_Type'Last, + "MTL < Integer_Type'Last" ); -- 255 < 1023 + Assert( MTM < Integer_Type'Last, + "MTM < Integer_Type'Last" ); -- 256 < 1023 + Assert( ENP > MTP, + "ENP > MTP" ); -- 3 > 1 + Assert( (FTS < MTL) or (FTS >= MTL), -- given FTS is impdef... + "(FTS < MTL) or (FTS >= MTL)" ); -- True + Assert( FTS > ITS, + "FTS > ITS" ); -- impdef > 3 + + Assert( MAFirst = Int_Array_Object'First, + "MAFirst = Int_Array_Object'First" ); -- 0 = 0 + Assert( IALast > MAFirst, + "IALast > MAFirst" ); -- 1023 > 0 + Assert( MAL < IAL, + "MAL < IAL" ); -- 255 < 1024 + + Assert( Mod2Flt = Flt2Fix, + "Mod2Flt = Flt2Fix" ); -- 2.0 = 2.0 + + end Check_Values; + +end C332001_0; + +------------------------------------------------------------------- C332001 + +with Report; +with C332001_0; +procedure C332001 is + +begin -- Main test procedure. + + Report.Test ("C332001", "Check that the static expression given for a " & + "number declaration may be of any numeric type. " & + "Check that the type of the named number is " & + "universal_integer of universal_real regardless " & + "of the type of the static expression that " & + "provides its value" ); + + C332001_0.Check_Values; + + Report.Result; + +end C332001; diff --git a/gcc-4.9/gcc/testsuite/ada/acats/tests/c3/c340001.a b/gcc-4.9/gcc/testsuite/ada/acats/tests/c3/c340001.a new file mode 100644 index 000000000..dce98bdb0 --- /dev/null +++ b/gcc-4.9/gcc/testsuite/ada/acats/tests/c3/c340001.a @@ -0,0 +1,470 @@ +-- C340001.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 user-defined equality operators are inherited by a +-- derived type except when the derived type is a nonlimited record +-- extension. In the latter case, ensure that the primitive +-- equality operation of the record extension compares any extended +-- components according to the predefined equality operators of the +-- component types. Also check that the parent portion of the extended +-- type is compared using the user-defined equality operation of the +-- parent type. +-- +-- TEST DESCRIPTION: +-- Declares a nonlimited tagged record and a limited tagged record +-- type, each in a separate package. A user-defined "=" operation is +-- defined for each type. Each type is extended with one new record +-- component added. +-- +-- Objects are declared for each parent and extended types and are +-- assigned values. For the limited type, modifier operations defined +-- in the package are used to assign values. +-- +-- To verify the use of the user-defined "=", values are assigned so +-- that predefined equality will return the opposite result if called. +-- Similarly, values are assigned to the extended type objects so that +-- one comparison will verify that the inherited components from the +-- parent are compared using the user-defined equality operation. +-- +-- A second comparison sets the values of the inherited components to +-- be the same so that equality based on the extended component may be +-- verified. For the nonlimited type, the test for equality should +-- fail, as the "=" defined for this type should include testing +-- equality of the extended component. For the limited type, "=" of the +-- parent should be inherited as-is, so the test for equality should +-- succeed even though the records differ in the extended component. +-- +-- A third package declares a discriminated tagged record. Equality +-- is user-defined and ignores the discriminant value. A type +-- extension is declared which also contains a discriminant. Since +-- an inherited discriminant may not be referenced other than in a +-- "new" discriminant, the type extension is also discriminated. The +-- discriminant is used as the constraint for the parent type. +-- +-- A variant part is declared in the type extension based on the new +-- discriminant. Comparisons are made to confirm that the user-defined +-- equality operator is used to compare values of the type extension. +-- Two record objects are given values so that user-defined equality +-- for the parent portion of the record succeeds, but the variant +-- parts in the type extended object differ. These objects are checked +-- to ensure that they are not equal. +-- +-- +-- CHANGE HISTORY: +-- 06 Dec 94 SAIC ACVC 2.0 +-- 19 Dec 94 SAIC Removed RM references from objective text. +-- +--! + +with Ada.Calendar; +package C340001_0 is + + type DB_Record is tagged record + Key : Natural range 1 .. 9999; + Data : String (1..10); + end record; + + function "=" (L, R : in DB_Record) return Boolean; + + type Dated_Record is new DB_Record with record + Retrieval_Time : Ada.Calendar.Time; + end record; + +end C340001_0; + +package body C340001_0 is + + function "=" (L, R : in DB_Record) return Boolean is + -- Key is ignored in determining equality of records + begin + return L.Data = R.Data; + end "="; + +end C340001_0; + +package C340001_1 is + + type List_Contents is array (1..10) of Integer; + type List is tagged limited record + Length : Natural range 0..10 := 0; + Contents : List_Contents := (others => 0); + end record; + + procedure Add_To (L : in out List; New_Value : in Integer); + procedure Remove_From (L : in out List); + + function "=" (L, R : in List) return Boolean; + + subtype Revision_Mark is Character range 'A' .. 'Z'; + type Revisable_List is new List with record + Revision : Revision_Mark := 'A'; + end record; + + procedure Revise (L : in out Revisable_List); + +end C340001_1; + +package body C340001_1 is + + -- Note: This is not a complete abstraction of a list. Exceptions + -- are not defined and boundary checks are not made. + + procedure Add_To (L : in out List; New_Value : in Integer) is + begin + L.Length := L.Length + 1; + L.Contents (L.Length) := New_Value; + end Add_To; + + procedure Remove_From (L : in out List) is + -- The list length is decremented. "Old" values are left in the + -- array. They are overwritten when a new value is added. + begin + L.Length := L.Length - 1; + end Remove_From; + + function "=" (L, R : in List) return Boolean is + -- Two lists are equal if they are the same length and + -- the component values within that length are the same. + -- Values stored past the end of the list are ignored. + begin + return L.Length = R.Length + and then L.Contents (1..L.Length) = R.Contents (1..R.Length); + end "="; + + procedure Revise (L : in out Revisable_List) is + begin + L.Revision := Character'Succ (L.Revision); + end Revise; + +end C340001_1; + +package C340001_2 is + + type Media is (Paper, Electronic); + + type Transaction (Medium : Media) is tagged record + ID : Natural range 1000 .. 9999; + end record; + + function "=" (L, R : in Transaction) return Boolean; + + type Authorization (Kind : Media) is new Transaction (Medium => Kind) + with record + case Kind is + when Paper => + Signature_On_File : Boolean; + when Electronic => + Paper_Backup : Boolean; -- to retain opposing value + end case; + end record; + +end C340001_2; + +package body C340001_2 is + + function "=" (L, R : in Transaction) return Boolean is + -- There may be electronic and paper copies of the same transaction. + -- The ID uniquely identifies a transaction. The medium (stored in + -- the discriminant) is ignored. + begin + return L.ID = R.ID; + end "="; + +end C340001_2; + + +with C340001_0; -- nonlimited tagged record declarations +with C340001_1; -- limited tagged record declarations +with C340001_2; -- tagged variant declarations +with Ada.Calendar; +with Report; +procedure C340001 is + + DB_Rec1 : C340001_0.DB_Record := (Key => 1, + Data => "aaaaaaaaaa"); + DB_Rec2 : C340001_0.DB_Record := (Key => 55, + Data => "aaaaaaaaaa"); + -- DB_Rec1 = DB_Rec2 using user-defined equality + -- DB_Rec1 /= DB_Rec2 using predefined equality + + Some_Time : Ada.Calendar.Time := + Ada.Calendar.Time_Of (Month => 9, Day => 16, Year => 1993); + + Another_Time : Ada.Calendar.Time := + Ada.Calendar.Time_Of (Month => 9, Day => 19, Year => 1993); + + Dated_Rec1 : C340001_0.Dated_Record := (Key => 2, + Data => "aaaaaaaaaa", + Retrieval_Time => Some_Time); + Dated_Rec2 : C340001_0.Dated_Record := (Key => 77, + Data => "aaaaaaaaaa", + Retrieval_Time => Some_Time); + Dated_Rec3 : C340001_0.Dated_Record := (Key => 77, + Data => "aaaaaaaaaa", + Retrieval_Time => Another_Time); + -- Dated_Rec1 = Dated_Rec2 if DB_Record."=" used for parent portion + -- Dated_Rec2 /= Dated_Rec3 if extended component is compared + -- using Ada.Calendar.Time."=" + + List1 : C340001_1.List; + List2 : C340001_1.List; + + RList1 : C340001_1.Revisable_List; + RList2 : C340001_1.Revisable_List; + RList3 : C340001_1.Revisable_List; + + Current : C340001_2.Transaction (C340001_2.Paper) := + (C340001_2.Paper, 2001); + Last : C340001_2.Transaction (C340001_2.Electronic) := + (C340001_2.Electronic, 2001); + -- Current = Last using user-defined equality + -- Current /= Last using predefined equality + + Approval1 : C340001_2.Authorization (C340001_2.Paper) + := (Kind => C340001_2.Paper, + ID => 1040, + Signature_On_File => True); + Approval2 : C340001_2.Authorization (C340001_2.Paper) + := (Kind => C340001_2.Paper, + ID => 2167, + Signature_On_File => False); + Approval3 : C340001_2.Authorization (C340001_2.Electronic) + := (Kind => C340001_2.Electronic, + ID => 2167, + Paper_Backup => False); + -- Approval1 /= Approval2 if user-defined equality extended with + -- component equality. + -- Approval2 /= Approval3 if differing variant parts checked + + -- Direct visibility to operator symbols + use type C340001_0.DB_Record; + use type C340001_0.Dated_Record; + + use type C340001_1.List; + use type C340001_1.Revisable_List; + + use type C340001_2.Transaction; + use type C340001_2.Authorization; + +begin + + Report.Test ("C340001", "Inheritance of user-defined ""="""); + + -- Approval1 /= Approval2 if user-defined equality extended with + -- component equality. + -- Approval2 /= Approval3 if differing variant parts checked + + --------------------------------------------------------------------- + -- Check that "=" and "/=" for the parent type call the user-defined + -- operation + --------------------------------------------------------------------- + + if not (DB_Rec1 = DB_Rec2) then + Report.Failed ("Nonlimited tagged record: " & + "User-defined equality did not override predefined " & + "equality"); + end if; + + if DB_Rec1 /= DB_Rec2 then + Report.Failed ("Nonlimited tagged record: " & + "User-defined equality did not override predefined " & + "inequality as well"); + end if; + + --------------------------------------------------------------------- + -- Check that "=" and "/=" for the type extension use the user-defined + -- equality operations from the parent to compare the inherited + -- components + --------------------------------------------------------------------- + + if not (Dated_Rec1 = Dated_Rec2) then + Report.Failed ("Nonlimited tagged record: " & + "User-defined equality was not used to compare " & + "components inherited from parent"); + end if; + + if Dated_Rec1 /= Dated_Rec2 then + Report.Failed ("Nonlimited tagged record: " & + "User-defined inequality was not used to compare " & + "components inherited from parent"); + end if; + + --------------------------------------------------------------------- + -- Check that equality and inequality for the type extension incorporate + -- the predefined equality operators for the extended component type + --------------------------------------------------------------------- + if Dated_Rec2 = Dated_Rec3 then + Report.Failed ("Nonlimited tagged record: " & + "Record equality was not extended with component " & + "equality"); + end if; + + if not (Dated_Rec2 /= Dated_Rec3) then + Report.Failed ("Nonlimited tagged record: " & + "Record inequality was not extended with component " & + "equality"); + end if; + + --------------------------------------------------------------------- + C340001_1.Add_To (List1, 1); + C340001_1.Add_To (List1, 2); + C340001_1.Add_To (List1, 3); + C340001_1.Remove_From (List1); + + C340001_1.Add_To (List2, 1); + C340001_1.Add_To (List2, 2); + + -- List1 contents are (2, (1, 2, 3, 0, 0, 0, 0, 0, 0, 0)) + -- List2 contents are (2, (1, 2, 0, 0, 0, 0, 0, 0, 0, 0)) + + -- List1 = List2 using user-defined equality + -- List1 /= List2 using predefined equality + + --------------------------------------------------------------------- + -- Check that "=" and "/=" for the parent type call the user-defined + -- operation + --------------------------------------------------------------------- + if not (List1 = List2) then + Report.Failed ("Limited tagged record : " & + "User-defined equality incorrectly implemented " ); + end if; + + if List1 /= List2 then + Report.Failed ("Limited tagged record : " & + "User-defined equality incorrectly implemented " ); + end if; + + --------------------------------------------------------------------- + -- RList1 and RList2 are made equal but "different" by adding + -- a nonzero value to RList1 then removing it. Removal updates + -- the list Length only, not its contents. The two lists will be + -- equal according to the defined list abstraction, but the records + -- will contain differing component values. + + C340001_1.Add_To (RList1, 1); + C340001_1.Add_To (RList1, 2); + C340001_1.Add_To (RList1, 3); + C340001_1.Remove_From (RList1); + + C340001_1.Add_To (RList2, 1); + C340001_1.Add_To (RList2, 2); + + C340001_1.Add_To (RList3, 1); + C340001_1.Add_To (RList3, 2); + + C340001_1.Revise (RList3); + + -- RList1 contents are (2, (1, 2, 3, 0, 0, 0, 0, 0, 0, 0), 'A') + -- RList2 contents are (2, (1, 2, 0, 0, 0, 0, 0, 0, 0, 0), 'A') + -- RList3 contents are (2, (1, 2, 0, 0, 0, 0, 0, 0, 0, 0), 'B') + + -- RList1 = RList2 if List."=" inherited + -- RList2 /= RList3 if List."=" inherited and extended with Character "=" + + --------------------------------------------------------------------- + -- Check that "=" and "/=" are the user-defined operations inherited + -- from the parent type. + --------------------------------------------------------------------- + if not (RList1 = RList2) then + Report.Failed ("Limited tagged record : " & + "User-defined equality was not inherited"); + end if; + + if RList1 /= RList2 then + Report.Failed ("Limited tagged record : " & + "User-defined inequality was not inherited"); + end if; + --------------------------------------------------------------------- + -- Check that "=" and "/=" for the type extension are NOT extended + -- with the predefined equality operators for the extended component. + -- A limited type extension should inherit the parent equality operation + -- as is. + --------------------------------------------------------------------- + if not (RList2 = RList3) then + Report.Failed ("Limited tagged record : " & + "Inherited equality operation was extended with " & + "component equality"); + end if; + + if RList2 /= RList3 then + Report.Failed ("Limited tagged record : " & + "Inherited inequality operation was extended with " & + "component equality"); + end if; + + --------------------------------------------------------------------- + -- Check that "=" and "/=" for the parent type call the user-defined + -- operation + --------------------------------------------------------------------- + if not (Current = Last) then + Report.Failed ("Variant record : " & + "User-defined equality did not override predefined " & + "equality"); + end if; + + if Current /= Last then + Report.Failed ("Variant record : " & + "User-defined inequality did not override predefined " & + "inequality"); + end if; + + --------------------------------------------------------------------- + -- Check that user-defined equality was incorporated and extended + -- with equality of extended components. + --------------------------------------------------------------------- + if not (Approval1 /= Approval2) then + Report.Failed ("Variant record : " & + "Inequality was not extended with component " & + "inequality"); + end if; + + if Approval1 = Approval2 then + Report.Failed ("Variant record : " & + "Equality was not extended with component " & + "equality"); + end if; + + --------------------------------------------------------------------- + -- Check that equality and inequality for the type extension + -- succeed despite the presence of differing variant parts. + --------------------------------------------------------------------- + if Approval2 = Approval3 then + Report.Failed ("Variant record : " & + "Equality succeeded even though variant parts " & + "in type extension differ"); + end if; + + if not (Approval2 /= Approval3) then + Report.Failed ("Variant record : " & + "Inequality failed even though variant parts " & + "in type extension differ"); + end if; + + --------------------------------------------------------------------- + Report.Result; + --------------------------------------------------------------------- + +end C340001; diff --git a/gcc-4.9/gcc/testsuite/ada/acats/tests/c3/c34001a.ada b/gcc-4.9/gcc/testsuite/ada/acats/tests/c3/c34001a.ada new file mode 100644 index 000000000..c66d7ddbc --- /dev/null +++ b/gcc-4.9/gcc/testsuite/ada/acats/tests/c3/c34001a.ada @@ -0,0 +1,186 @@ +-- C34001A.ADA + +-- Grant of Unlimited Rights +-- +-- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687, +-- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained +-- unlimited rights in the software and documentation contained herein. +-- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making +-- this public release, the Government intends to confer upon all +-- recipients unlimited rights equal to those held by the Government. +-- These rights include rights to use, duplicate, release or disclose the +-- released technical data and computer software in whole or in part, in +-- any manner and for any purpose whatsoever, and to have or permit others +-- to do so. +-- +-- DISCLAIMER +-- +-- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR +-- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED +-- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF 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 REQUIRED PREDEFINED OPERATIONS ARE DECLARED +-- (IMPLICITLY) FOR DERIVED ENUMERATION TYPES, EXCLUDING BOOLEAN TYPES. + +-- JRK 8/20/86 + +WITH SYSTEM; USE SYSTEM; +WITH REPORT; USE REPORT; + +PROCEDURE C34001A IS + + TYPE PARENT IS (E1, E2, E3, 'A', E4, E5, E6); + + SUBTYPE SUBPARENT IS PARENT RANGE + PARENT'VAL (IDENT_INT (PARENT'POS (E2))) .. + PARENT'VAL (IDENT_INT (PARENT'POS (E5))); + + TYPE T IS NEW SUBPARENT RANGE + PARENT'VAL (IDENT_INT (PARENT'POS (E3))) .. + PARENT'VAL (IDENT_INT (PARENT'POS (E4))); + + X : T := E3; + W : PARENT := E1; + B : BOOLEAN := FALSE; + + PROCEDURE A (X : ADDRESS) IS + BEGIN + B := IDENT_BOOL (TRUE); + END A; + + FUNCTION IDENT (X : T) RETURN T IS + BEGIN + IF EQUAL (T'POS (X), T'POS (X)) THEN + RETURN X; -- ALWAYS EXECUTED. + END IF; + RETURN T'FIRST; + END IDENT; + +BEGIN + TEST ("C34001A", "CHECK THAT THE REQUIRED PREDEFINED OPERATIONS " & + "ARE DECLARED (IMPLICITLY) FOR DERIVED " & + "ENUMERATION TYPES, EXCLUDING BOOLEAN TYPES"); + + X := IDENT (E4); + IF X /= E4 THEN + FAILED ("INCORRECT :="); + END IF; + + IF T'(X) /= E4 THEN + FAILED ("INCORRECT QUALIFICATION"); + END IF; + + IF T (X) /= E4 THEN + FAILED ("INCORRECT SELF CONVERSION"); + END IF; + + IF EQUAL (3, 3) THEN + W := E3; + END IF; + IF T (W) /= E3 THEN + FAILED ("INCORRECT CONVERSION FROM PARENT"); + END IF; + + IF PARENT (X) /= E4 OR PARENT (T'VAL (0)) /= E1 THEN + FAILED ("INCORRECT CONVERSION TO PARENT"); + END IF; + + IF IDENT ('A') /= 'A' THEN + FAILED ("INCORRECT 'A'"); + END IF; + + IF IDENT (E3) /= E3 OR IDENT (E4) = E1 THEN + FAILED ("INCORRECT ENUMERATION LITERAL"); + END IF; + + IF X = IDENT ('A') OR X = E1 THEN + FAILED ("INCORRECT ="); + END IF; + + IF X /= IDENT (E4) OR NOT (X /= E1) THEN + FAILED ("INCORRECT /="); + END IF; + + IF X < IDENT (E4) OR X < E1 THEN + FAILED ("INCORRECT <"); + END IF; + + IF X > IDENT (E4) OR X > E6 THEN + FAILED ("INCORRECT >"); + END IF; + + IF X <= IDENT ('A') OR X <= E1 THEN + FAILED ("INCORRECT <="); + END IF; + + IF IDENT ('A') >= X OR X >= E6 THEN + FAILED ("INCORRECT >="); + END IF; + + IF NOT (X IN T) OR E1 IN T THEN + FAILED ("INCORRECT ""IN"""); + END IF; + + IF X NOT IN T OR NOT (E1 NOT IN T) THEN + FAILED ("INCORRECT ""NOT IN"""); + END IF; + + B := FALSE; + A (X'ADDRESS); + IF NOT B THEN + FAILED ("INCORRECT 'ADDRESS"); + END IF; + + IF T'BASE'SIZE < 3 THEN + FAILED ("INCORRECT 'BASE'SIZE"); + END IF; + + IF T'FIRST /= E3 OR T'BASE'FIRST /= E1 THEN + FAILED ("INCORRECT 'FIRST"); + END IF; + + IF T'IMAGE (X) /= "E4" OR T'IMAGE (E1) /= "E1" THEN + FAILED ("INCORRECT 'IMAGE"); + END IF; + + IF T'LAST /= E4 OR T'BASE'LAST /= E6 THEN + FAILED ("INCORRECT 'LAST"); + END IF; + + IF T'POS (X) /= 4 OR T'POS (E1) /= 0 THEN + FAILED ("INCORRECT 'POS"); + END IF; + + IF T'PRED (X) /= 'A' OR T'PRED (E2) /= E1 THEN + FAILED ("INCORRECT 'PRED"); + END IF; + + IF T'SIZE < 2 THEN + FAILED ("INCORRECT TYPE'SIZE"); + END IF; + + IF X'SIZE < 2 THEN + FAILED ("INCORRECT OBJECT'SIZE"); + END IF; + + IF T'SUCC (IDENT ('A')) /= X OR T'SUCC (E1) /= E2 THEN + FAILED ("INCORRECT 'SUCC"); + END IF; + + IF T'VAL (IDENT_INT (4)) /= X OR T'VAL (0) /= E1 THEN + FAILED ("INCORRECT 'VAL"); + END IF; + + IF T'VALUE (IDENT_STR ("E4")) /= X OR T'VALUE ("E1") /= E1 THEN + FAILED ("INCORRECT 'VALUE"); + END IF; + + IF T'WIDTH /= 3 OR T'BASE'WIDTH /= 3 THEN + FAILED ("INCORRECT 'WIDTH"); + END IF; + + RESULT; +END C34001A; diff --git a/gcc-4.9/gcc/testsuite/ada/acats/tests/c3/c34001c.ada b/gcc-4.9/gcc/testsuite/ada/acats/tests/c3/c34001c.ada new file mode 100644 index 000000000..a4509db4a --- /dev/null +++ b/gcc-4.9/gcc/testsuite/ada/acats/tests/c3/c34001c.ada @@ -0,0 +1,150 @@ +-- C34001C.ADA + +-- Grant of Unlimited Rights +-- +-- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687, +-- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained +-- unlimited rights in the software and documentation contained herein. +-- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making +-- this public release, the Government intends to confer upon all +-- recipients unlimited rights equal to those held by the Government. +-- These rights include rights to use, duplicate, release or disclose the +-- released technical data and computer software in whole or in part, in +-- any manner and for any purpose whatsoever, and to have or permit others +-- to do so. +-- +-- DISCLAIMER +-- +-- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR +-- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED +-- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE +-- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE +-- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A +-- PARTICULAR PURPOSE OF SAID MATERIAL. +--* +-- FOR DERIVED ENUMERATION TYPES, EXCLUDING BOOLEAN TYPES: + +-- CHECK THAT ALL VALUES OF THE PARENT (BASE) TYPE ARE PRESENT FOR THE +-- DERIVED (BASE) TYPE WHEN THE DERIVED TYPE DEFINITION IS +-- CONSTRAINED. + +-- CHECK THAT ANY CONSTRAINT IMPOSED ON THE PARENT SUBTYPE IS ALSO +-- IMPOSED ON THE DERIVED SUBTYPE. + +-- JRK 8/20/86 + +WITH REPORT; USE REPORT; + +PROCEDURE C34001C IS + + TYPE PARENT IS (E1, E2, E3, 'A', E4, E5, E6); + + TYPE T IS NEW PARENT RANGE + PARENT'VAL (IDENT_INT (PARENT'POS (E3))) .. + PARENT'VAL (IDENT_INT (PARENT'POS (E4))); + + SUBTYPE SUBPARENT IS PARENT RANGE E3 .. E4; + + TYPE S IS NEW SUBPARENT; + + X : T; + Y : S; + +BEGIN + TEST ("C34001C", "CHECK THAT ALL VALUES OF THE PARENT (BASE) " & + "TYPE ARE PRESENT FOR THE DERIVED (BASE) TYPE " & + "WHEN THE DERIVED TYPE DEFINITION IS " & + "CONSTRAINED. ALSO CHECK THAT ANY CONSTRAINT " & + "IMPOSED ON THE PARENT SUBTYPE IS ALSO IMPOSED " & + "ON THE DERIVED SUBTYPE. CHECK FOR DERIVED " & + "ENUMERATION TYPES, EXCLUDING BOOLEAN TYPES"); + + -- CHECK THAT BASE TYPE VALUES NOT IN THE SUBTYPE ARE PRESENT. + + IF T'BASE'FIRST /= E1 OR T'BASE'LAST /= E6 OR + S'BASE'FIRST /= E1 OR S'BASE'LAST /= E6 THEN + FAILED ("INCORRECT 'BASE'FIRST OR 'BASE'LAST"); + END IF; + + IF T'PRED (E2) /= E1 OR T'SUCC (E1) /= E2 OR + S'PRED (E2) /= E1 OR S'SUCC (E1) /= E2 THEN + FAILED ("INCORRECT 'PRED OR 'SUCC"); + END IF; + + -- CHECK THE DERIVED SUBTYPE CONSTRAINT. + + IF T'FIRST /= E3 OR T'LAST /= E4 OR + S'FIRST /= E3 OR S'LAST /= E4 THEN + FAILED ("INCORRECT 'FIRST OR 'LAST"); + END IF; + + BEGIN + X := E3; + Y := E3; + IF PARENT (X) /= PARENT (Y) THEN -- USE X AND Y. + FAILED ("INCORRECT CONVERSION TO PARENT - 1"); + END IF; + X := E4; + Y := E4; + IF PARENT (X) /= PARENT (Y) THEN -- USE X AND Y. + FAILED ("INCORRECT CONVERSION TO PARENT - 2"); + END IF; + EXCEPTION + WHEN OTHERS => + FAILED ("EXCEPTION RAISED BY OK ASSIGNMENT"); + END; + + BEGIN + X := E2; + FAILED ("CONSTRAINT_ERROR NOT RAISED -- X := E2"); + IF X = E2 THEN -- USE X. + COMMENT ("X ALTERED -- X := E2"); + END IF; + EXCEPTION + WHEN CONSTRAINT_ERROR => + NULL; + WHEN OTHERS => + FAILED ("WRONG EXCEPTION RAISED -- X := E2"); + END; + + BEGIN + X := E5; + FAILED ("CONSTRAINT_ERROR NOT RAISED -- X := E5"); + IF X = E5 THEN -- USE X. + COMMENT ("X ALTERED -- X := E5"); + END IF; + EXCEPTION + WHEN CONSTRAINT_ERROR => + NULL; + WHEN OTHERS => + FAILED ("WRONG EXCEPTION RAISED -- X := E5"); + END; + + BEGIN + Y := E2; + FAILED ("CONSTRAINT_ERROR NOT RAISED -- Y := E2"); + IF Y = E2 THEN -- USE Y. + COMMENT ("Y ALTERED -- Y := E2"); + END IF; + EXCEPTION + WHEN CONSTRAINT_ERROR => + NULL; + WHEN OTHERS => + FAILED ("WRONG EXCEPTION RAISED -- Y := E2"); + END; + + BEGIN + Y := E5; + FAILED ("CONSTRAINT_ERROR NOT RAISED -- Y := E5"); + IF Y = E5 THEN -- USE Y. + COMMENT ("Y ALTERED -- Y := E5"); + END IF; + EXCEPTION + WHEN CONSTRAINT_ERROR => + NULL; + WHEN OTHERS => + FAILED ("WRONG EXCEPTION RAISED -- Y := E5"); + END; + + RESULT; +END C34001C; diff --git a/gcc-4.9/gcc/testsuite/ada/acats/tests/c3/c34001d.ada b/gcc-4.9/gcc/testsuite/ada/acats/tests/c3/c34001d.ada new file mode 100644 index 000000000..7b9832898 --- /dev/null +++ b/gcc-4.9/gcc/testsuite/ada/acats/tests/c3/c34001d.ada @@ -0,0 +1,209 @@ +-- C34001D.ADA + +-- Grant of Unlimited Rights +-- +-- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687, +-- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained +-- unlimited rights in the software and documentation contained herein. +-- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making +-- this public release, the Government intends to confer upon all +-- recipients unlimited rights equal to those held by the Government. +-- These rights include rights to use, duplicate, release or disclose the +-- released technical data and computer software in whole or in part, in +-- any manner and for any purpose whatsoever, and to have or permit others +-- to do so. +-- +-- DISCLAIMER +-- +-- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR +-- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED +-- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF 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 REQUIRED PREDEFINED OPERATIONS ARE DECLARED +-- (IMPLICITLY) FOR DERIVED BOOLEAN TYPES. + +-- JRK 8/20/86 + +WITH SYSTEM; USE SYSTEM; +WITH REPORT; USE REPORT; + +PROCEDURE C34001D IS + + SUBTYPE PARENT IS BOOLEAN; + + SUBTYPE SUBPARENT IS PARENT RANGE + PARENT'VAL (IDENT_INT (PARENT'POS (FALSE))) .. + PARENT'VAL (IDENT_INT (PARENT'POS (TRUE))); + + TYPE T IS NEW SUBPARENT RANGE + PARENT'VAL (IDENT_INT (PARENT'POS (TRUE))) .. + PARENT'VAL (IDENT_INT (PARENT'POS (TRUE))); + + X : T := TRUE; + W : PARENT := FALSE; + B : BOOLEAN := FALSE; + + PROCEDURE A (X : ADDRESS) IS + BEGIN + B := IDENT_BOOL (TRUE); + END A; + + FUNCTION IDENT (X : T) RETURN T IS + BEGIN + IF EQUAL (T'POS (X), T'POS (X)) THEN + RETURN X; -- ALWAYS EXECUTED. + END IF; + RETURN T'FIRST; + END IDENT; + +BEGIN + TEST ("C34001D", "CHECK THAT THE REQUIRED PREDEFINED OPERATIONS " & + "ARE DECLARED (IMPLICITLY) FOR DERIVED " & + "BOOLEAN TYPES"); + + X := IDENT (TRUE); + IF X /= TRUE THEN + FAILED ("INCORRECT :="); + END IF; + + IF T'(X) /= TRUE THEN + FAILED ("INCORRECT QUALIFICATION"); + END IF; + + IF T (X) /= TRUE THEN + FAILED ("INCORRECT SELF CONVERSION"); + END IF; + + IF EQUAL (3, 3) THEN + W := TRUE; + END IF; + IF T (W) /= TRUE THEN + FAILED ("INCORRECT CONVERSION FROM PARENT"); + END IF; + + IF PARENT (X) /= TRUE OR PARENT (T'VAL (0)) /= FALSE THEN + FAILED ("INCORRECT CONVERSION TO PARENT"); + END IF; + + IF IDENT (TRUE) /= TRUE OR IDENT (TRUE) = FALSE THEN + FAILED ("INCORRECT ENUMERATION LITERAL"); + END IF; + + IF NOT X /= FALSE OR NOT FALSE /= X THEN + FAILED ("INCORRECT ""NOT"""); + END IF; + + IF (X AND IDENT (TRUE)) /= TRUE OR (X AND FALSE) /= FALSE THEN + FAILED ("INCORRECT ""AND"""); + END IF; + + IF (X OR IDENT (TRUE)) /= TRUE OR (FALSE OR X) /= TRUE THEN + FAILED ("INCORRECT ""OR"""); + END IF; + + IF (X XOR IDENT (TRUE)) /= FALSE OR (X XOR FALSE) /= TRUE THEN + FAILED ("INCORRECT ""XOR"""); + END IF; + + IF (X AND THEN IDENT (TRUE)) /= TRUE OR + (X AND THEN FALSE) /= FALSE THEN + FAILED ("INCORRECT ""AND THEN"""); + END IF; + + IF (X OR ELSE IDENT (TRUE)) /= TRUE OR + (FALSE OR ELSE X) /= TRUE THEN + FAILED ("INCORRECT ""OR ELSE"""); + END IF; + + IF NOT (X = IDENT (TRUE)) OR X = FALSE THEN + FAILED ("INCORRECT ="); + END IF; + + IF X /= IDENT (TRUE) OR NOT (X /= FALSE) THEN + FAILED ("INCORRECT /="); + END IF; + + IF X < IDENT (TRUE) OR X < FALSE THEN + FAILED ("INCORRECT <"); + END IF; + + IF X > IDENT (TRUE) OR FALSE > X THEN + FAILED ("INCORRECT >"); + END IF; + + IF NOT (X <= IDENT (TRUE)) OR X <= FALSE THEN + FAILED ("INCORRECT <="); + END IF; + + IF NOT (X >= IDENT (TRUE)) OR FALSE >= X THEN + FAILED ("INCORRECT >="); + END IF; + + IF NOT (X IN T) OR FALSE IN T THEN + FAILED ("INCORRECT ""IN"""); + END IF; + + IF X NOT IN T OR NOT (FALSE NOT IN T) THEN + FAILED ("INCORRECT ""NOT IN"""); + END IF; + + B := FALSE; + A (X'ADDRESS); + IF NOT B THEN + FAILED ("INCORRECT 'ADDRESS"); + END IF; + + IF T'BASE'SIZE < 1 THEN + FAILED ("INCORRECT 'BASE'SIZE"); + END IF; + + IF T'FIRST /= TRUE OR T'BASE'FIRST /= FALSE THEN + FAILED ("INCORRECT 'FIRST"); + END IF; + + IF T'IMAGE (X) /= "TRUE" OR T'IMAGE (FALSE) /= "FALSE" THEN + FAILED ("INCORRECT 'IMAGE"); + END IF; + + IF T'LAST /= TRUE OR T'BASE'LAST /= TRUE THEN + FAILED ("INCORRECT 'LAST"); + END IF; + + IF T'POS (X) /= 1 OR T'POS (FALSE) /= 0 THEN + FAILED ("INCORRECT 'POS"); + END IF; + + IF T'PRED (X) /= FALSE THEN + FAILED ("INCORRECT 'PRED"); + END IF; + + IF T'SIZE < 1 THEN + FAILED ("INCORRECT TYPE'SIZE"); + END IF; + + IF X'SIZE < 1 THEN + FAILED ("INCORRECT OBJECT'SIZE"); + END IF; + + IF T'SUCC (T'VAL (IDENT_INT (0))) /= X THEN + FAILED ("INCORRECT 'SUCC"); + END IF; + + IF T'VAL (IDENT_INT (1)) /= X OR T'VAL (0) /= FALSE THEN + FAILED ("INCORRECT 'VAL"); + END IF; + + IF T'VALUE (IDENT_STR ("TRUE")) /= X OR + T'VALUE ("FALSE") /= FALSE THEN + FAILED ("INCORRECT 'VALUE"); + END IF; + + IF T'WIDTH /= 4 OR T'BASE'WIDTH /= 5 THEN + FAILED ("INCORRECT 'WIDTH"); + END IF; + + RESULT; +END C34001D; diff --git a/gcc-4.9/gcc/testsuite/ada/acats/tests/c3/c34001f.ada b/gcc-4.9/gcc/testsuite/ada/acats/tests/c3/c34001f.ada new file mode 100644 index 000000000..6226e7291 --- /dev/null +++ b/gcc-4.9/gcc/testsuite/ada/acats/tests/c3/c34001f.ada @@ -0,0 +1,119 @@ +-- C34001F.ADA + +-- Grant of Unlimited Rights +-- +-- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687, +-- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained +-- unlimited rights in the software and documentation contained herein. +-- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making +-- this public release, the Government intends to confer upon all +-- recipients unlimited rights equal to those held by the Government. +-- These rights include rights to use, duplicate, release or disclose the +-- released technical data and computer software in whole or in part, in +-- any manner and for any purpose whatsoever, and to have or permit others +-- to do so. +-- +-- DISCLAIMER +-- +-- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR +-- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED +-- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE +-- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE +-- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A +-- PARTICULAR PURPOSE OF SAID MATERIAL. +--* +-- FOR DERIVED BOOLEAN TYPES: + +-- CHECK THAT ALL VALUES OF THE PARENT (BASE) TYPE ARE PRESENT FOR THE +-- DERIVED (BASE) TYPE WHEN THE DERIVED TYPE DEFINITION IS +-- CONSTRAINED. + +-- CHECK THAT ANY CONSTRAINT IMPOSED ON THE PARENT SUBTYPE IS ALSO +-- IMPOSED ON THE DERIVED SUBTYPE. + +-- JRK 8/20/86 + +WITH REPORT; USE REPORT; + +PROCEDURE C34001F IS + + SUBTYPE PARENT IS BOOLEAN; + + TYPE T IS NEW PARENT RANGE + PARENT'VAL (IDENT_INT (PARENT'POS (FALSE))) .. + PARENT'VAL (IDENT_INT (PARENT'POS (FALSE))); + + SUBTYPE SUBPARENT IS PARENT RANGE TRUE .. TRUE; + + TYPE S IS NEW SUBPARENT; + + X : T; + Y : S; + +BEGIN + TEST ("C34001F", "CHECK THAT ALL VALUES OF THE PARENT (BASE) " & + "TYPE ARE PRESENT FOR THE DERIVED (BASE) TYPE " & + "WHEN THE DERIVED TYPE DEFINITION IS " & + "CONSTRAINED. ALSO CHECK THAT ANY CONSTRAINT " & + "IMPOSED ON THE PARENT SUBTYPE IS ALSO IMPOSED " & + "ON THE DERIVED SUBTYPE. CHECK FOR DERIVED " & + "BOOLEAN TYPES"); + + -- CHECK THAT BASE TYPE VALUES NOT IN THE SUBTYPE ARE PRESENT. + + IF T'BASE'FIRST /= FALSE OR T'BASE'LAST /= TRUE OR + S'BASE'FIRST /= FALSE OR S'BASE'LAST /= TRUE THEN + FAILED ("INCORRECT 'BASE'FIRST OR 'BASE'LAST"); + END IF; + + IF T'PRED (TRUE) /= FALSE OR T'SUCC (FALSE) /= TRUE OR + S'PRED (TRUE) /= FALSE OR S'SUCC (FALSE) /= TRUE THEN + FAILED ("INCORRECT 'PRED OR 'SUCC"); + END IF; + + -- CHECK THE DERIVED SUBTYPE CONSTRAINT. + + IF T'FIRST /= FALSE OR T'LAST /= FALSE OR + S'FIRST /= TRUE OR S'LAST /= TRUE THEN + FAILED ("INCORRECT 'FIRST OR 'LAST"); + END IF; + + BEGIN + X := FALSE; + Y := TRUE; + IF NOT PARENT (X) /= PARENT (Y) THEN -- USE X AND Y. + FAILED ("INCORRECT CONVERSION TO PARENT"); + END IF; + EXCEPTION + WHEN OTHERS => + FAILED ("EXCEPTION RAISED BY OK ASSIGNMENT"); + END; + + BEGIN + X := TRUE; + FAILED ("CONSTRAINT_ERROR NOT RAISED -- X := TRUE"); + IF X = TRUE THEN -- USE X. + COMMENT ("X ALTERED -- X := TRUE"); + END IF; + EXCEPTION + WHEN CONSTRAINT_ERROR => + NULL; + WHEN OTHERS => + FAILED ("WRONG EXCEPTION RAISED -- X := TRUE"); + END; + + BEGIN + Y := FALSE; + FAILED ("CONSTRAINT_ERROR NOT RAISED -- Y := FALSE"); + IF Y = FALSE THEN -- USE Y. + COMMENT ("Y ALTERED -- Y := FALSE"); + END IF; + EXCEPTION + WHEN CONSTRAINT_ERROR => + NULL; + WHEN OTHERS => + FAILED ("WRONG EXCEPTION RAISED -- Y := FALSE"); + END; + + RESULT; +END C34001F; diff --git a/gcc-4.9/gcc/testsuite/ada/acats/tests/c3/c34002a.ada b/gcc-4.9/gcc/testsuite/ada/acats/tests/c3/c34002a.ada new file mode 100644 index 000000000..8b5690e20 --- /dev/null +++ b/gcc-4.9/gcc/testsuite/ada/acats/tests/c3/c34002a.ada @@ -0,0 +1,265 @@ +-- C34002A.ADA + +-- Grant of Unlimited Rights +-- +-- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687, +-- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained +-- unlimited rights in the software and documentation contained herein. +-- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making +-- this public release, the Government intends to confer upon all +-- recipients unlimited rights equal to those held by the Government. +-- These rights include rights to use, duplicate, release or disclose the +-- released technical data and computer software in whole or in part, in +-- any manner and for any purpose whatsoever, and to have or permit others +-- to do so. +-- +-- DISCLAIMER +-- +-- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR +-- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED +-- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF 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 REQUIRED PREDEFINED OPERATIONS ARE DECLARED +-- (IMPLICITLY) FOR DERIVED INTEGER TYPES. + +-- JRK 8/21/86 + +WITH SYSTEM; USE SYSTEM; +WITH REPORT; USE REPORT; + +PROCEDURE C34002A IS + + TYPE PARENT IS RANGE -100 .. 100; + + SUBTYPE SUBPARENT IS PARENT RANGE + PARENT'VAL (IDENT_INT (-50)) .. + PARENT'VAL (IDENT_INT ( 50)); + + TYPE T IS NEW SUBPARENT RANGE + PARENT'VAL (IDENT_INT (-30)) .. + PARENT'VAL (IDENT_INT ( 30)); + + TYPE FIXED IS DELTA 0.1 RANGE -1000.0 .. 1000.0; + + X : T := -30; + W : PARENT := -100; + N : CONSTANT := 1; + M : CONSTANT := 100; + B : BOOLEAN := FALSE; + F : FLOAT := 0.0; + G : FIXED := 0.0; + + PROCEDURE A (X : ADDRESS) IS + BEGIN + B := IDENT_BOOL (TRUE); + END A; + + FUNCTION IDENT (X : T) RETURN T IS + BEGIN + IF EQUAL (T'POS (X), T'POS (X)) THEN + RETURN X; -- ALWAYS EXECUTED. + END IF; + RETURN T'FIRST; + END IDENT; + +BEGIN + TEST ("C34002A", "CHECK THAT THE REQUIRED PREDEFINED OPERATIONS " & + "ARE DECLARED (IMPLICITLY) FOR DERIVED " & + "INTEGER TYPES"); + + X := IDENT (30); + IF X /= 30 THEN + FAILED ("INCORRECT :="); + END IF; + + IF T'(X) /= 30 THEN + FAILED ("INCORRECT QUALIFICATION"); + END IF; + + IF T (X) /= 30 THEN + FAILED ("INCORRECT SELF CONVERSION"); + END IF; + + IF EQUAL (3, 3) THEN + W := -30; + END IF; + IF T (W) /= -30 THEN + FAILED ("INCORRECT CONVERSION FROM PARENT"); + END IF; + + IF PARENT (X) /= 30 OR PARENT (T'VAL (-100)) /= -100 THEN + FAILED ("INCORRECT CONVERSION TO PARENT"); + END IF; + + IF T (IDENT_INT (-30)) /= -30 THEN + FAILED ("INCORRECT CONVERSION FROM INTEGER"); + END IF; + + IF INTEGER (X) /= 30 OR INTEGER (T'VAL (-100)) /= -100 THEN + FAILED ("INCORRECT CONVERSION TO INTEGER"); + END IF; + + IF EQUAL (3, 3) THEN + F := -30.0; + END IF; + IF T (F) /= -30 THEN + FAILED ("INCORRECT CONVERSION FROM FLOAT"); + END IF; + + IF FLOAT (X) /= 30.0 OR FLOAT (T'VAL (-100)) /= -100.0 THEN + FAILED ("INCORRECT CONVERSION TO FLOAT"); + END IF; + + IF EQUAL (3, 3) THEN + G := -30.0; + END IF; + IF T (G) /= -30 THEN + FAILED ("INCORRECT CONVERSION FROM FIXED"); + END IF; + + IF FIXED (X) /= 30.0 OR FIXED (T'VAL (-100)) /= -100.0 THEN + FAILED ("INCORRECT CONVERSION TO FIXED"); + END IF; + + IF IDENT (N) /= 1 OR X = M THEN + FAILED ("INCORRECT IMPLICIT CONVERSION"); + END IF; + + IF IDENT (30) /= 30 OR X = 100 THEN + FAILED ("INCORRECT INTEGER LITERAL"); + END IF; + + IF X = IDENT (0) OR X = 100 THEN + FAILED ("INCORRECT ="); + END IF; + + IF X /= IDENT (30) OR NOT (X /= 100) THEN + FAILED ("INCORRECT /="); + END IF; + + IF X < IDENT (30) OR 100 < X THEN + FAILED ("INCORRECT <"); + END IF; + + IF X > IDENT (30) OR X > 100 THEN + FAILED ("INCORRECT >"); + END IF; + + IF X <= IDENT (0) OR 100 <= X THEN + FAILED ("INCORRECT <="); + END IF; + + IF IDENT (0) >= X OR X >= 100 THEN + FAILED ("INCORRECT >="); + END IF; + + IF NOT (X IN T) OR 100 IN T THEN + FAILED ("INCORRECT ""IN"""); + END IF; + + IF X NOT IN T OR NOT (100 NOT IN T) THEN + FAILED ("INCORRECT ""NOT IN"""); + END IF; + + IF +X /= 30 OR +T'VAL(-100) /= -100 THEN + FAILED ("INCORRECT UNARY +"); + END IF; + + IF -X /= 0 - 30 OR -T'VAL(-100) /= 100 THEN + FAILED ("INCORRECT UNARY -"); + END IF; + + IF ABS X /= 30 OR ABS T'VAL (-100) /= 100 THEN + FAILED ("INCORRECT ABS"); + END IF; + + IF X + IDENT (-1) /= 29 OR X + 70 /= 100 THEN + FAILED ("INCORRECT BINARY +"); + END IF; + + IF X - IDENT (30) /= 0 OR X - 100 /= -70 THEN + FAILED ("INCORRECT BINARY -"); + END IF; + + IF X * IDENT (-1) /= -30 OR IDENT (2) * 50 /= 100 THEN + FAILED ("INCORRECT *"); + END IF; + + IF X / IDENT (3) /= 10 OR 90 / X /= 3 THEN + FAILED ("INCORRECT /"); + END IF; + + IF X MOD IDENT (7) /= 2 OR 100 MOD X /= 10 THEN + FAILED ("INCORRECT MOD"); + END IF; + + IF X REM IDENT (7) /= 2 OR 100 REM X /= 10 THEN + FAILED ("INCORRECT REM"); + END IF; + + IF X ** IDENT_INT (1) /= 30 OR + T'VAL (100) ** IDENT_INT (1) /= 100 THEN + FAILED ("INCORRECT **"); + END IF; + + B := FALSE; + A (X'ADDRESS); + IF NOT B THEN + FAILED ("INCORRECT 'ADDRESS"); + END IF; + + IF T'BASE'SIZE < 8 THEN + FAILED ("INCORRECT 'BASE'SIZE"); + END IF; + + IF T'FIRST /= -30 OR + T'POS (T'BASE'FIRST) /= PARENT'POS (PARENT'BASE'FIRST) THEN + FAILED ("INCORRECT 'FIRST"); + END IF; + + IF T'IMAGE (X) /= " 30" OR T'IMAGE (-100) /= "-100" THEN + FAILED ("INCORRECT 'IMAGE"); + END IF; + + IF T'LAST /= 30 OR + T'POS (T'BASE'LAST) /= PARENT'POS (PARENT'BASE'LAST) THEN + FAILED ("INCORRECT 'LAST"); + END IF; + + IF T'POS (X) /= 30 OR T'POS (-100) /= -100 THEN + FAILED ("INCORRECT 'POS"); + END IF; + + IF T'PRED (X) /= 29 OR T'PRED (100) /= 99 THEN + FAILED ("INCORRECT 'PRED"); + END IF; + + IF T'SIZE < 6 THEN + FAILED ("INCORRECT TYPE'SIZE"); + END IF; + + IF X'SIZE < 6 THEN + FAILED ("INCORRECT OBJECT'SIZE"); + END IF; + + IF T'SUCC (IDENT (29)) /= X OR T'SUCC (99) /= 100 THEN + FAILED ("INCORRECT 'SUCC"); + END IF; + + IF T'VAL (IDENT_INT (30)) /= X OR T'VAL (100) /= 100 THEN + FAILED ("INCORRECT 'VAL"); + END IF; + + IF T'VALUE (IDENT_STR ("30")) /= X OR T'VALUE ("100") /= 100 THEN + FAILED ("INCORRECT 'VALUE"); + END IF; + + IF T'WIDTH /= 3 OR T'BASE'WIDTH < 4 THEN + FAILED ("INCORRECT 'WIDTH"); + END IF; + + RESULT; +END C34002A; diff --git a/gcc-4.9/gcc/testsuite/ada/acats/tests/c3/c34002c.ada b/gcc-4.9/gcc/testsuite/ada/acats/tests/c3/c34002c.ada new file mode 100644 index 000000000..a14459d33 --- /dev/null +++ b/gcc-4.9/gcc/testsuite/ada/acats/tests/c3/c34002c.ada @@ -0,0 +1,152 @@ +-- C34002C.ADA + +-- Grant of Unlimited Rights +-- +-- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687, +-- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained +-- unlimited rights in the software and documentation contained herein. +-- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making +-- this public release, the Government intends to confer upon all +-- recipients unlimited rights equal to those held by the Government. +-- These rights include rights to use, duplicate, release or disclose the +-- released technical data and computer software in whole or in part, in +-- any manner and for any purpose whatsoever, and to have or permit others +-- to do so. +-- +-- DISCLAIMER +-- +-- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR +-- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED +-- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE +-- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE +-- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A +-- PARTICULAR PURPOSE OF SAID MATERIAL. +--* +-- FOR DERIVED INTEGER TYPES: + +-- CHECK THAT ALL VALUES OF THE PARENT (BASE) TYPE ARE PRESENT FOR THE +-- DERIVED (BASE) TYPE WHEN THE DERIVED TYPE DEFINITION IS +-- CONSTRAINED. + +-- CHECK THAT ANY CONSTRAINT IMPOSED ON THE PARENT SUBTYPE IS ALSO +-- IMPOSED ON THE DERIVED SUBTYPE. + +-- JRK 8/21/86 + +WITH REPORT; USE REPORT; + +PROCEDURE C34002C IS + + TYPE PARENT IS RANGE -100 .. 100; + + TYPE T IS NEW PARENT RANGE + PARENT'VAL (IDENT_INT (-30)) .. + PARENT'VAL (IDENT_INT ( 30)); + + SUBTYPE SUBPARENT IS PARENT RANGE -30 .. 30; + + TYPE S IS NEW SUBPARENT; + + X : T; + Y : S; + +BEGIN + TEST ("C34002C", "CHECK THAT ALL VALUES OF THE PARENT (BASE) " & + "TYPE ARE PRESENT FOR THE DERIVED (BASE) TYPE " & + "WHEN THE DERIVED TYPE DEFINITION IS " & + "CONSTRAINED. ALSO CHECK THAT ANY CONSTRAINT " & + "IMPOSED ON THE PARENT SUBTYPE IS ALSO IMPOSED " & + "ON THE DERIVED SUBTYPE. CHECK FOR DERIVED " & + "INTEGER TYPES"); + + -- CHECK THAT BASE TYPE VALUES NOT IN THE SUBTYPE ARE PRESENT. + + IF T'POS (T'BASE'FIRST) /= PARENT'POS (PARENT'BASE'FIRST) OR + S'POS (S'BASE'FIRST) /= PARENT'POS (PARENT'BASE'FIRST) OR + T'POS (T'BASE'LAST) /= PARENT'POS (PARENT'BASE'LAST) OR + S'POS (S'BASE'LAST) /= PARENT'POS (PARENT'BASE'LAST) THEN + FAILED ("INCORRECT 'BASE'FIRST OR 'BASE'LAST"); + END IF; + + IF T'PRED (100) /= 99 OR T'SUCC (99) /= 100 OR + S'PRED (100) /= 99 OR S'SUCC (99) /= 100 THEN + FAILED ("INCORRECT 'PRED OR 'SUCC"); + END IF; + + -- CHECK THE DERIVED SUBTYPE CONSTRAINT. + + IF T'FIRST /= -30 OR T'LAST /= 30 OR + S'FIRST /= -30 OR S'LAST /= 30 THEN + FAILED ("INCORRECT 'FIRST OR 'LAST"); + END IF; + + BEGIN + X := -30; + Y := -30; + IF PARENT (X) /= PARENT (Y) THEN -- USE X AND Y. + FAILED ("INCORRECT CONVERSION TO PARENT - 1"); + END IF; + X := 30; + Y := 30; + IF PARENT (X) /= PARENT (Y) THEN -- USE X AND Y. + FAILED ("INCORRECT CONVERSION TO PARENT - 2"); + END IF; + EXCEPTION + WHEN OTHERS => + FAILED ("EXCEPTION RAISED BY OK ASSIGNMENT"); + END; + + BEGIN + X := -31; + FAILED ("CONSTRAINT_ERROR NOT RAISED -- X := -31"); + IF X = -31 THEN -- USE X. + COMMENT ("X ALTERED -- X := -31"); + END IF; + EXCEPTION + WHEN CONSTRAINT_ERROR => + NULL; + WHEN OTHERS => + FAILED ("WRONG EXCEPTION RAISED -- X := -31"); + END; + + BEGIN + X := 31; + FAILED ("CONSTRAINT_ERROR NOT RAISED -- X := 31"); + IF X = 31 THEN -- USE X. + COMMENT ("X ALTERED -- X := 31"); + END IF; + EXCEPTION + WHEN CONSTRAINT_ERROR => + NULL; + WHEN OTHERS => + FAILED ("WRONG EXCEPTION RAISED -- X := 31"); + END; + + BEGIN + Y := -31; + FAILED ("CONSTRAINT_ERROR NOT RAISED -- Y := -31"); + IF Y = -31 THEN -- USE Y. + COMMENT ("Y ALTERED -- Y := -31"); + END IF; + EXCEPTION + WHEN CONSTRAINT_ERROR => + NULL; + WHEN OTHERS => + FAILED ("WRONG EXCEPTION RAISED -- Y := -31"); + END; + + BEGIN + Y := 31; + FAILED ("CONSTRAINT_ERROR NOT RAISED -- Y := 31"); + IF Y = 31 THEN -- USE Y. + COMMENT ("Y ALTERED -- Y := 31"); + END IF; + EXCEPTION + WHEN CONSTRAINT_ERROR => + NULL; + WHEN OTHERS => + FAILED ("WRONG EXCEPTION RAISED -- Y := 31"); + END; + + RESULT; +END C34002C; diff --git a/gcc-4.9/gcc/testsuite/ada/acats/tests/c3/c34003a.ada b/gcc-4.9/gcc/testsuite/ada/acats/tests/c3/c34003a.ada new file mode 100644 index 000000000..ed37d0585 --- /dev/null +++ b/gcc-4.9/gcc/testsuite/ada/acats/tests/c3/c34003a.ada @@ -0,0 +1,260 @@ +-- C34003A.ADA + +-- Grant of Unlimited Rights +-- +-- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687, +-- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained +-- unlimited rights in the software and documentation contained herein. +-- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making +-- this public release, the Government intends to confer upon all +-- recipients unlimited rights equal to those held by the Government. +-- These rights include rights to use, duplicate, release or disclose the +-- released technical data and computer software in whole or in part, in +-- any manner and for any purpose whatsoever, and to have or permit others +-- to do so. +-- +-- DISCLAIMER +-- +-- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR +-- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED +-- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF 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 REQUIRED PREDEFINED OPERATIONS ARE DECLARED +-- (IMPLICITLY) FOR DERIVED FLOATING POINT TYPES. + +-- JRK 9/4/86 +-- GJD 11/14/95 REMOVED USES OF OBSOLETE ADA 83 ATTRIBUTES. + +WITH SYSTEM; USE SYSTEM; +WITH REPORT; USE REPORT; + +PROCEDURE C34003A IS + + TYPE PARENT IS DIGITS 5; + + SUBTYPE SUBPARENT IS PARENT RANGE + PARENT (IDENT_INT (-50)) .. + PARENT (IDENT_INT ( 50)); + + TYPE T IS NEW SUBPARENT DIGITS 4 RANGE + PARENT (IDENT_INT (-30)) .. + PARENT (IDENT_INT ( 30)); + + TYPE FIXED IS DELTA 0.1 RANGE -1000.0 .. 1000.0; + + X : T := -30.0; + W : PARENT := -100.0; + R : CONSTANT := 1.0; + M : CONSTANT := 100.0; + B : BOOLEAN := FALSE; + F : FLOAT := 0.0; + G : FIXED := 0.0; + + Z : CONSTANT T := 0.0; + + PROCEDURE A (X : ADDRESS) IS + BEGIN + B := IDENT_BOOL (TRUE); + END A; + + FUNCTION IDENT (X : T) RETURN T IS + BEGIN + IF EQUAL (3, 3) THEN + RETURN X; -- ALWAYS EXECUTED. + END IF; + RETURN T'FIRST; + END IDENT; + +BEGIN + TEST ("C34003A", "CHECK THAT THE REQUIRED PREDEFINED OPERATIONS " & + "ARE DECLARED (IMPLICITLY) FOR DERIVED " & + "FLOATING POINT TYPES"); + + X := IDENT (30.0); + IF X /= 30.0 THEN + FAILED ("INCORRECT :="); + END IF; + + IF T'(X) /= 30.0 THEN + FAILED ("INCORRECT QUALIFICATION"); + END IF; + + IF T (X) /= 30.0 THEN + FAILED ("INCORRECT SELF CONVERSION"); + END IF; + + IF EQUAL (3, 3) THEN + W := -30.0; + END IF; + IF T (W) /= -30.0 THEN + FAILED ("INCORRECT CONVERSION FROM PARENT"); + END IF; + + IF PARENT (X) /= 30.0 OR PARENT (Z - 100.0) /= -100.0 THEN + FAILED ("INCORRECT CONVERSION TO PARENT"); + END IF; + + IF T (IDENT_INT (-30)) /= -30.0 THEN + FAILED ("INCORRECT CONVERSION FROM INTEGER"); + END IF; + + IF INTEGER (X) /= 30 OR INTEGER (Z - 100.0) /= -100 THEN + FAILED ("INCORRECT CONVERSION TO INTEGER"); + END IF; + + IF EQUAL (3, 3) THEN + F := -30.0; + END IF; + IF T (F) /= -30.0 THEN + FAILED ("INCORRECT CONVERSION FROM FLOAT"); + END IF; + + IF FLOAT (X) /= 30.0 OR FLOAT (Z - 100.0) /= -100.0 THEN + FAILED ("INCORRECT CONVERSION TO FLOAT"); + END IF; + + IF EQUAL (3, 3) THEN + G := -30.0; + END IF; + IF T (G) /= -30.0 THEN + FAILED ("INCORRECT CONVERSION FROM FIXED"); + END IF; + + IF FIXED (X) /= 30.0 OR FIXED (Z - 100.0) /= -100.0 THEN + FAILED ("INCORRECT CONVERSION TO FIXED"); + END IF; + + IF IDENT (R) /= 1.0 OR X = M THEN + FAILED ("INCORRECT IMPLICIT CONVERSION"); + END IF; + + IF IDENT (30.0) /= 30.0 OR X = 100.0 THEN + FAILED ("INCORRECT REAL LITERAL"); + END IF; + + IF X = IDENT (0.0) OR X = 100.0 THEN + FAILED ("INCORRECT ="); + END IF; + + IF X /= IDENT (30.0) OR NOT (X /= 100.0) THEN + FAILED ("INCORRECT /="); + END IF; + + IF X < IDENT (30.0) OR 100.0 < X THEN + FAILED ("INCORRECT <"); + END IF; + + IF X > IDENT (30.0) OR X > 100.0 THEN + FAILED ("INCORRECT >"); + END IF; + + IF X <= IDENT (0.0) OR 100.0 <= X THEN + FAILED ("INCORRECT <="); + END IF; + + IF IDENT (0.0) >= X OR X >= 100.0 THEN + FAILED ("INCORRECT >="); + END IF; + + IF NOT (X IN T) OR 100.0 IN T THEN + FAILED ("INCORRECT ""IN"""); + END IF; + + IF X NOT IN T OR NOT (100.0 NOT IN T) THEN + FAILED ("INCORRECT ""NOT IN"""); + END IF; + + IF +X /= 30.0 OR +(Z - 100.0) /= -100.0 THEN + FAILED ("INCORRECT UNARY +"); + END IF; + + IF -X /= 0.0 - 30.0 OR -(Z - 100.0) /= 100.0 THEN + FAILED ("INCORRECT UNARY -"); + END IF; + + IF ABS X /= 30.0 OR ABS (Z - 100.0) /= 100.0 THEN + FAILED ("INCORRECT ABS"); + END IF; + + IF X + IDENT (-1.0) /= 29.0 OR X + 70.0 /= 100.0 THEN + FAILED ("INCORRECT BINARY +"); + END IF; + + IF X - IDENT (30.0) /= 0.0 OR X - 100.0 /= -70.0 THEN + FAILED ("INCORRECT BINARY -"); + END IF; + + IF X * IDENT (-1.0) /= -30.0 OR IDENT (2.0) * 50.0 /= 100.0 THEN + FAILED ("INCORRECT *"); + END IF; + + IF X / IDENT (3.0) /= 10.0 OR 90.0 / X /= 3.0 THEN + FAILED ("INCORRECT /"); + END IF; + + IF X ** IDENT_INT (1) /= 30.0 OR + (Z + 100.0) ** IDENT_INT (1) /= 100.0 THEN + FAILED ("INCORRECT **"); + END IF; + + B := FALSE; + A (X'ADDRESS); + IF NOT B THEN + FAILED ("INCORRECT 'ADDRESS"); + END IF; + + IF T'BASE'SIZE < 27 THEN + FAILED ("INCORRECT 'BASE'SIZE"); + END IF; + + IF T'DIGITS /= 4 OR T'BASE'DIGITS < 5 THEN + FAILED ("INCORRECT 'DIGITS"); + END IF; + + IF T'FIRST /= -30.0 THEN + FAILED ("INCORRECT 'FIRST"); + END IF; + + IF T'LAST /= 30.0 THEN + FAILED ("INCORRECT 'LAST"); + END IF; + + IF T'MACHINE_EMAX < 1 OR T'BASE'MACHINE_EMAX /= T'MACHINE_EMAX THEN + FAILED ("INCORRECT 'MACHINE_EMAX"); + END IF; + + IF T'MACHINE_EMIN > -1 OR T'BASE'MACHINE_EMIN /= T'MACHINE_EMIN THEN + FAILED ("INCORRECT 'MACHINE_EMIN"); + END IF; + + IF T'MACHINE_MANTISSA < 1 OR + T'BASE'MACHINE_MANTISSA /= T'MACHINE_MANTISSA THEN + FAILED ("INCORRECT 'MACHINE_MANTISSA"); + END IF; + + IF T'MACHINE_OVERFLOWS /= T'BASE'MACHINE_OVERFLOWS THEN + FAILED ("INCORRECT 'MACHINE_OVERFLOWS"); + END IF; + + IF T'MACHINE_RADIX < 2 OR + T'BASE'MACHINE_RADIX /= T'MACHINE_RADIX THEN + FAILED ("INCORRECT 'MACHINE_RADIX"); + END IF; + + IF T'MACHINE_ROUNDS /= T'BASE'MACHINE_ROUNDS THEN + FAILED ("INCORRECT 'MACHINE_ROUNDS"); + END IF; + + IF T'SIZE < 23 THEN + FAILED ("INCORRECT TYPE'SIZE"); + END IF; + + IF X'SIZE < 23 THEN + FAILED ("INCORRECT OBJECT'SIZE"); + END IF; + + RESULT; +END C34003A; diff --git a/gcc-4.9/gcc/testsuite/ada/acats/tests/c3/c34003c.ada b/gcc-4.9/gcc/testsuite/ada/acats/tests/c3/c34003c.ada new file mode 100644 index 000000000..9de3574af --- /dev/null +++ b/gcc-4.9/gcc/testsuite/ada/acats/tests/c3/c34003c.ada @@ -0,0 +1,156 @@ +-- C34003C.ADA + +-- Grant of Unlimited Rights +-- +-- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687, +-- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained +-- unlimited rights in the software and documentation contained herein. +-- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making +-- this public release, the Government intends to confer upon all +-- recipients unlimited rights equal to those held by the Government. +-- These rights include rights to use, duplicate, release or disclose the +-- released technical data and computer software in whole or in part, in +-- any manner and for any purpose whatsoever, and to have or permit others +-- to do so. +-- +-- DISCLAIMER +-- +-- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR +-- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED +-- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE +-- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE +-- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A +-- PARTICULAR PURPOSE OF SAID MATERIAL. +--* +-- FOR DERIVED FLOATING POINT TYPES: + +-- CHECK THAT ALL VALUES OF THE PARENT (BASE) TYPE ARE PRESENT FOR THE +-- DERIVED (BASE) TYPE WHEN THE DERIVED TYPE DEFINITION IS +-- CONSTRAINED. + +-- CHECK THAT ANY CONSTRAINT IMPOSED ON THE PARENT SUBTYPE IS ALSO +-- IMPOSED ON THE DERIVED SUBTYPE. + +-- JRK 9/4/86 +-- GJD 11/15/95 REMOVED USES OF OBSOLETE ADA 83 ATTRIBUTE (SAFE_LARGE). + +WITH REPORT; USE REPORT; + +PROCEDURE C34003C IS + + TYPE PARENT IS DIGITS 5; + + TYPE T IS NEW PARENT DIGITS 4 RANGE + PARENT (IDENT_INT (-30)) .. + PARENT (IDENT_INT ( 30)); + + SUBTYPE SUBPARENT IS PARENT DIGITS 4 RANGE -30.0 .. 30.0; + + TYPE S IS NEW SUBPARENT; + + X : T; + Y : S; + +BEGIN + TEST ("C34003C", "CHECK THAT ALL VALUES OF THE PARENT (BASE) " & + "TYPE ARE PRESENT FOR THE DERIVED (BASE) TYPE " & + "WHEN THE DERIVED TYPE DEFINITION IS " & + "CONSTRAINED. ALSO CHECK THAT ANY CONSTRAINT " & + "IMPOSED ON THE PARENT SUBTYPE IS ALSO IMPOSED " & + "ON THE DERIVED SUBTYPE. CHECK FOR DERIVED " & + "FLOATING POINT TYPES"); + + -- CHECK THAT BASE TYPE VALUES NOT IN THE SUBTYPE ARE PRESENT. + + IF T'BASE'DIGITS < 5 OR S'BASE'DIGITS < 5 THEN + FAILED ("INCORRECT 'BASE'DIGITS"); + END IF; + + IF 12344.0 + T'(1.0) + 1.0 /= 12346.0 OR + 12344.0 + S'(1.0) + 1.0 /= 12346.0 OR + -12344.0 - T'(1.0) - 1.0 /= -12346.0 OR + -12344.0 - S'(1.0) - 1.0 /= -12346.0 THEN + FAILED ("INCORRECT + OR -"); + END IF; + + -- CHECK THE DERIVED SUBTYPE CONSTRAINT. + + IF T'DIGITS /= 4 OR S'DIGITS /= 4 THEN + FAILED ("INCORRECT 'DIGITS"); + END IF; + + IF T'FIRST /= -30.0 OR T'LAST /= 30.0 OR + S'FIRST /= -30.0 OR S'LAST /= 30.0 THEN + FAILED ("INCORRECT 'FIRST OR 'LAST"); + END IF; + + BEGIN + X := -30.0; + Y := -30.0; + IF PARENT (X) /= PARENT (Y) THEN -- USE X AND Y. + FAILED ("INCORRECT CONVERSION TO PARENT - 1"); + END IF; + X := 30.0; + Y := 30.0; + IF PARENT (X) /= PARENT (Y) THEN -- USE X AND Y. + FAILED ("INCORRECT CONVERSION TO PARENT - 2"); + END IF; + EXCEPTION + WHEN OTHERS => + FAILED ("EXCEPTION RAISED BY OK ASSIGNMENT"); + END; + + BEGIN + X := -31.0; + FAILED ("CONSTRAINT_ERROR NOT RAISED -- X := -31.0"); + IF X = -31.0 THEN -- USE X. + COMMENT ("X ALTERED -- X := -31.0"); + END IF; + EXCEPTION + WHEN CONSTRAINT_ERROR => + NULL; + WHEN OTHERS => + FAILED ("WRONG EXCEPTION RAISED -- X := -31.0"); + END; + + BEGIN + X := 31.0; + FAILED ("CONSTRAINT_ERROR NOT RAISED -- X := 31.0"); + IF X = 31.0 THEN -- USE X. + COMMENT ("X ALTERED -- X := 31.0"); + END IF; + EXCEPTION + WHEN CONSTRAINT_ERROR => + NULL; + WHEN OTHERS => + FAILED ("WRONG EXCEPTION RAISED -- X := 31.0"); + END; + + BEGIN + Y := -31.0; + FAILED ("CONSTRAINT_ERROR NOT RAISED -- Y := -31.0"); + IF Y = -31.0 THEN -- USE Y. + COMMENT ("Y ALTERED -- Y := -31.0"); + END IF; + EXCEPTION + WHEN CONSTRAINT_ERROR => + NULL; + WHEN OTHERS => + FAILED ("WRONG EXCEPTION RAISED -- Y := -31.0"); + END; + + BEGIN + Y := 31.0; + FAILED ("CONSTRAINT_ERROR NOT RAISED -- Y := 31.0"); + IF Y = 31.0 THEN -- USE Y. + COMMENT ("Y ALTERED -- Y := 31.0"); + END IF; + EXCEPTION + WHEN CONSTRAINT_ERROR => + NULL; + WHEN OTHERS => + FAILED ("WRONG EXCEPTION RAISED -- Y := 31.0"); + END; + + RESULT; +END C34003C; diff --git a/gcc-4.9/gcc/testsuite/ada/acats/tests/c3/c34004a.ada b/gcc-4.9/gcc/testsuite/ada/acats/tests/c3/c34004a.ada new file mode 100644 index 000000000..735776a19 --- /dev/null +++ b/gcc-4.9/gcc/testsuite/ada/acats/tests/c3/c34004a.ada @@ -0,0 +1,267 @@ +-- C34004A.ADA + +-- Grant of Unlimited Rights +-- +-- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687, +-- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained +-- unlimited rights in the software and documentation contained herein. +-- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making +-- this public release, the Government intends to confer upon all +-- recipients unlimited rights equal to those held by the Government. +-- These rights include rights to use, duplicate, release or disclose the +-- released technical data and computer software in whole or in part, in +-- any manner and for any purpose whatsoever, and to have or permit others +-- to do so. +-- +-- DISCLAIMER +-- +-- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR +-- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED +-- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF 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 REQUIRED PREDEFINED OPERATIONS ARE DECLARED +-- (IMPLICITLY) FOR DERIVED FIXED POINT TYPES. + +-- HISTORY: +-- JRK 09/08/86 CREATED ORIGINAL TEST. +-- JET 08/06/87 FIXED BUGS IN DELTAS AND RANGE ERROR. +-- JET 09/22/88 CHANGED USAGE OF X'SIZE. +-- RDH 04/16/90 ADDED TEST FOR REAL VARIABLE VALUES. +-- THS 09/25/90 REMOVED ALL REFERENCES TO B, MODIFIED CHECK OF +-- '=', INITIALIZED Z NON-STATICALLY, MOVED BINARY +-- CHECKS. +-- DTN 11/30/95 REMOVED NON ADA95 ATTRIBUTES. +-- KAS 03/04/96 REMOVED COMPARISON OF T'SMALL TO T'BASE'SMALL + +WITH SYSTEM; USE SYSTEM; +WITH REPORT; USE REPORT; + +PROCEDURE C34004A IS + + TYPE PARENT IS DELTA 2.0 ** (-7) RANGE -100.0 .. 100.0; + + SUBTYPE SUBPARENT IS PARENT RANGE + IDENT_INT (1) * (-50.0) .. + IDENT_INT (1) * ( 50.0); + + TYPE T IS NEW SUBPARENT DELTA 2.0 ** (-4) RANGE + IDENT_INT (1) * (-30.0) .. + IDENT_INT (1) * ( 30.0); + + TYPE FIXED IS DELTA 2.0 ** (-4) RANGE -1000.0 .. 1000.0; + + X : T := -30.0; + I : INTEGER := X'SIZE; --CHECK FOR THE AVAILABILITY OF 'SIZE. + W : PARENT := -100.0; + R : CONSTANT := 1.0; + M : CONSTANT := 100.0; + F : FLOAT := 0.0; + G : FIXED := 0.0; + + PROCEDURE A (X : ADDRESS) IS + BEGIN + NULL; + END A; + + FUNCTION IDENT (X : T) RETURN T IS + BEGIN + IF EQUAL (3, 3) THEN + RETURN X; -- ALWAYS EXECUTED. + END IF; + RETURN T'FIRST; + END IDENT; + +BEGIN + + DECLARE + Z : CONSTANT T := IDENT(0.0); + BEGIN + TEST ("C34004A", "CHECK THAT THE REQUIRED PREDEFINED " & + "OPERATIONS ARE DECLARED (IMPLICITLY) " & + "FOR DERIVED FIXED POINT TYPES"); + + X := IDENT (30.0); + IF X /= 30.0 THEN + FAILED ("INCORRECT :="); + END IF; + + IF X + IDENT (-1.0) /= 29.0 OR X + 70.0 /= 100.0 THEN + FAILED ("INCORRECT BINARY +"); + END IF; + + IF X - IDENT (30.0) /= 0.0 OR X - 100.0 /= -70.0 THEN + FAILED ("INCORRECT BINARY -"); + END IF; + + IF T'(X) /= 30.0 THEN + FAILED ("INCORRECT QUALIFICATION"); + END IF; + + IF T (X) /= 30.0 THEN + FAILED ("INCORRECT SELF CONVERSION"); + END IF; + + IF EQUAL (3, 3) THEN + W := -30.0; + END IF; + IF T (W) /= -30.0 THEN + FAILED ("INCORRECT CONVERSION FROM PARENT"); + END IF; + + IF PARENT (X) /= 30.0 OR PARENT (Z - 100.0) /= -100.0 THEN + FAILED ("INCORRECT CONVERSION TO PARENT"); + END IF; + + IF T (IDENT_INT (-30)) /= -30.0 THEN + FAILED ("INCORRECT CONVERSION FROM INTEGER"); + END IF; + + IF INTEGER (X) /= 30 OR INTEGER (Z - 100.0) /= -100 THEN + FAILED ("INCORRECT CONVERSION TO INTEGER"); + END IF; + + IF EQUAL (3, 3) THEN + F := -30.0; + END IF; + IF T (F) /= -30.0 THEN + FAILED ("INCORRECT CONVERSION FROM FLOAT"); + END IF; + + IF FLOAT (X) /= 30.0 OR FLOAT (Z - 100.0) /= -100.0 THEN + FAILED ("INCORRECT CONVERSION TO FLOAT"); + END IF; + + IF EQUAL (3, 3) THEN + G := -30.0; + END IF; + IF T (G) /= -30.0 THEN + FAILED ("INCORRECT CONVERSION FROM FIXED"); + END IF; + + IF FIXED (X) /= 30.0 OR FIXED (Z - 100.0) /= -100.0 THEN + FAILED ("INCORRECT CONVERSION TO FIXED"); + END IF; + + IF IDENT (R) /= 1.0 OR X = M THEN + FAILED ("INCORRECT IMPLICIT CONVERSION"); + END IF; + + IF IDENT (30.0) /= 30.0 OR X = 100.0 THEN + FAILED ("INCORRECT REAL LITERAL"); + END IF; + + IF NOT (X = IDENT (30.0)) THEN + FAILED ("INCORRECT ="); + END IF; + + IF X /= IDENT (30.0) OR NOT (X /= 100.0) THEN + FAILED ("INCORRECT /="); + END IF; + + IF X < IDENT (30.0) OR 100.0 < X THEN + FAILED ("INCORRECT <"); + END IF; + + IF X > IDENT (30.0) OR X > 100.0 THEN + FAILED ("INCORRECT >"); + END IF; + + IF X <= IDENT (0.0) OR 100.0 <= X THEN + FAILED ("INCORRECT <="); + END IF; + + IF IDENT (0.0) >= X OR X >= 100.0 THEN + FAILED ("INCORRECT >="); + END IF; + + IF NOT (X IN T) OR 100.0 IN T THEN + FAILED ("INCORRECT ""IN"""); + END IF; + + IF X NOT IN T OR NOT (100.0 NOT IN T) THEN + FAILED ("INCORRECT ""NOT IN"""); + END IF; + + IF +X /= 30.0 OR +(Z - 100.0) /= -100.0 THEN + FAILED ("INCORRECT UNARY +"); + END IF; + + IF -X /= 0.0 - 30.0 OR -(Z - 100.0) /= 100.0 THEN + FAILED ("INCORRECT UNARY -"); + END IF; + + IF ABS X /= 30.0 OR ABS (Z - 100.0) /= 100.0 THEN + FAILED ("INCORRECT ABS"); + END IF; + + IF T (X * IDENT (-1.0)) /= -30.0 OR + T (IDENT (2.0) * (Z + 15.0)) /= 30.0 THEN + FAILED ("INCORRECT * (FIXED, FIXED)"); + END IF; + + IF X * IDENT_INT (-1) /= -30.0 OR + (Z + 50.0) * 2 /= 100.0 THEN + FAILED ("INCORRECT * (FIXED, INTEGER)"); + END IF; + + IF IDENT_INT (-1) * X /= -30.0 OR + 2 * (Z + 50.0) /= 100.0 THEN + FAILED ("INCORRECT * (INTEGER, FIXED)"); + END IF; + + IF T (X / IDENT (3.0)) /= 10.0 OR + T ((Z + 90.0) / X) /= 3.0 THEN + FAILED ("INCORRECT / (FIXED, FIXED)"); + END IF; + + IF X / IDENT_INT (3) /= 10.0 OR (Z + 90.0) / 30 /= 3.0 THEN + FAILED ("INCORRECT / (FIXED, INTEGER)"); + END IF; + + A (X'ADDRESS); + + IF T'AFT /= 2 OR T'BASE'AFT < 3 THEN + FAILED ("INCORRECT 'AFT"); + END IF; + + IF T'BASE'SIZE < 15 THEN + FAILED ("INCORRECT 'BASE'SIZE"); + END IF; + + IF T'DELTA /= 2.0 ** (-4) OR T'BASE'DELTA > 2.0 ** (-7) THEN + FAILED ("INCORRECT 'DELTA"); + END IF; + + + IF T'FORE /= 3 OR T'BASE'FORE < 4 THEN + FAILED ("INCORRECT 'FORE"); + END IF; + + + + IF T'MACHINE_OVERFLOWS /= T'BASE'MACHINE_OVERFLOWS THEN + FAILED ("INCORRECT 'MACHINE_OVERFLOWS"); + END IF; + + IF T'MACHINE_ROUNDS /= T'BASE'MACHINE_ROUNDS THEN + FAILED ("INCORRECT 'MACHINE_ROUNDS"); + END IF; + + + + + IF T'SIZE < 10 THEN + FAILED ("INCORRECT TYPE'SIZE"); + END IF; + + IF T'SMALL > 2.0 ** (-4) OR T'BASE'SMALL > 2.0 ** (-7) THEN + FAILED ("INCORRECT 'SMALL"); + END IF; + END; + + RESULT; +END C34004A; diff --git a/gcc-4.9/gcc/testsuite/ada/acats/tests/c3/c34004c.ada b/gcc-4.9/gcc/testsuite/ada/acats/tests/c3/c34004c.ada new file mode 100644 index 000000000..d3b699f77 --- /dev/null +++ b/gcc-4.9/gcc/testsuite/ada/acats/tests/c3/c34004c.ada @@ -0,0 +1,191 @@ +-- C34004C.ADA + +-- Grant of Unlimited Rights +-- +-- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687, +-- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained +-- unlimited rights in the software and documentation contained herein. +-- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making +-- this public release, the Government intends to confer upon all +-- recipients unlimited rights equal to those held by the Government. +-- These rights include rights to use, duplicate, release or disclose the +-- released technical data and computer software in whole or in part, in +-- any manner and for any purpose whatsoever, and to have or permit others +-- to do so. +-- +-- DISCLAIMER +-- +-- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR +-- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED +-- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE +-- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE +-- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A +-- PARTICULAR PURPOSE OF SAID MATERIAL. +--* +-- OBJECTIVE: +-- FOR DERIVED FIXED POINT TYPES: + +-- CHECK THAT ALL VALUES OF THE PARENT (BASE) TYPE ARE PRESENT FOR +-- THE DERIVED (BASE) TYPE WHEN THE DERIVED TYPE DEFINITION IS +-- CONSTRAINED. + +-- CHECK THAT ANY CONSTRAINT IMPOSED ON THE PARENT SUBTYPE IS ALSO +-- IMPOSED ON THE DERIVED SUBTYPE. + +-- HISTORY: +-- JRK 09/08/86 +-- JLH 09/25/87 REFORMATTED HEADER. +-- JRL 03/13/92 MODIFIED TO DEFEAT OPTIMIZATION WHEN ATTEMPTING TO +-- RAISE CONSTRAINT_ERROR. +-- JRL 03/30/93 REMOVED NUMERIC_ERROR FROM TEST. +-- DTN 11/30/95 REMOVED NON ADA95 ATTRIBUTES. + +WITH SYSTEM; USE SYSTEM; +WITH REPORT; USE REPORT; + +PROCEDURE C34004C IS + + TYPE PARENT IS DELTA 0.01 RANGE -100.0 .. 100.0; + + TYPE T IS NEW PARENT DELTA 0.1 RANGE + IDENT_INT (1) * (-30.0) .. + IDENT_INT (1) * ( 30.0); + + SUBTYPE SUBPARENT IS PARENT DELTA 0.1 RANGE -30.0 .. 30.0; + + TYPE S IS NEW SUBPARENT; + + X,XA : T; + Y,YA : S; + + + FUNCTION OUT_OF_BOUNDS ( VAR1 , VAR2 : T ) RETURN BOOLEAN IS + BEGIN + IF ( VAR1 + VAR2 ) IN T THEN + RETURN FALSE ; + ELSE + RETURN TRUE ; + END IF ; + EXCEPTION + WHEN CONSTRAINT_ERROR => + RETURN TRUE ; + END OUT_OF_BOUNDS ; + + + FUNCTION OUT_OF_BOUNDS ( VAR1 , VAR2 : S ) RETURN BOOLEAN IS + BEGIN + IF ( VAR1 + VAR2 ) IN S THEN + RETURN FALSE ; + ELSE + RETURN TRUE ; + END IF ; + EXCEPTION + WHEN CONSTRAINT_ERROR => + RETURN TRUE ; + END OUT_OF_BOUNDS ; + + +BEGIN + TEST ("C34004C", "CHECK THAT ALL VALUES OF THE PARENT (BASE) " & + "TYPE ARE PRESENT FOR THE DERIVED (BASE) TYPE " & + "WHEN THE DERIVED TYPE DEFINITION IS " & + "CONSTRAINED. ALSO CHECK THAT ANY CONSTRAINT " & + "IMPOSED ON THE PARENT SUBTYPE IS ALSO IMPOSED " & + "ON THE DERIVED SUBTYPE. CHECK FOR DERIVED " & + "FIXED POINT TYPES"); + + -- CHECK THAT BASE TYPE VALUES NOT IN THE SUBTYPE ARE PRESENT. + + DECLARE + TBD : CONSTANT := BOOLEAN'POS (T'BASE'DELTA <= 0.01); + SBD : CONSTANT := BOOLEAN'POS (S'BASE'DELTA <= 0.01); + BEGIN + IF TBD = 0 OR SBD = 0 THEN + FAILED ("INCORRECT 'BASE'DELTA"); + END IF; + END; + + + DECLARE + N : INTEGER := IDENT_INT (8); + BEGIN + IF 98.0 + T'(1.0) + N * 0.0078125 /= 99.0625 OR + 98.0 + S'(1.0) + 8 * 0.0078125 /= 99.0625 OR + -98.0 - T'(1.0) - N * 0.0078125 /= -99.0625 OR + -98.0 - S'(1.0) - 8 * 0.0078125 /= -99.0625 THEN + FAILED ("INCORRECT + OR -"); + END IF; + END; + + + IF T'FIRST /= -30.0 OR T'LAST /= 30.0 OR + S'FIRST /= -30.0 OR S'LAST /= 30.0 THEN + FAILED ("INCORRECT 'FIRST OR 'LAST"); + END IF; + + BEGIN + X := -30.0; + Y := -30.0; + IF PARENT (X) /= PARENT (Y) THEN -- USE X AND Y. + FAILED ("INCORRECT CONVERSION TO PARENT - 1"); + END IF; + X := 30.0; + Y := 30.0; + IF PARENT (X) /= PARENT (Y) THEN -- USE X AND Y. + FAILED ("INCORRECT CONVERSION TO PARENT - 2"); + END IF; + EXCEPTION + WHEN OTHERS => + FAILED ("EXCEPTION RAISED BY OK ASSIGNMENT"); + END; + + + BEGIN + X := -30.0 ; + XA := -0.0625 ; + IF NOT OUT_OF_BOUNDS ( X , XA ) THEN + FAILED ( "CONSTRAINT_ERROR NOT RAISED -- X := -30.0625" ) ; + END IF ; + EXCEPTION + WHEN OTHERS => + FAILED ("WRONG EXCEPTION RAISED -- X := -30.0625"); + END; + + + BEGIN + X := 30.0 ; + XA := 0.0625 ; + IF NOT OUT_OF_BOUNDS ( X , XA ) THEN + FAILED ( "CONSTRAINT_ERROR NOT RAISED -- X := 30.0625" ) ; + END IF ; + EXCEPTION + WHEN OTHERS => + FAILED ("WRONG EXCEPTION RAISED -- X := 30.0625"); + END; + + + BEGIN + Y := -30.0 ; + YA := -0.0625 ; + IF NOT OUT_OF_BOUNDS ( Y , YA ) THEN + FAILED ( "CONSTRAINT_ERROR NOT RAISED -- Y := -30.0625" ) ; + END IF ; + EXCEPTION + WHEN OTHERS => + FAILED ("WRONG EXCEPTION RAISED -- Y := -30.0625"); + END; + + + BEGIN + Y := 30.0 ; + YA := 0.0625 ; + IF NOT OUT_OF_BOUNDS ( Y , YA ) THEN + FAILED ( "CONSTRAINT_ERROR NOT RAISED -- Y := 30.0625" ) ; + END IF ; + EXCEPTION + WHEN OTHERS => + FAILED ("WRONG EXCEPTION RAISED -- Y := 30.0625"); + END; + + RESULT; +END C34004C; diff --git a/gcc-4.9/gcc/testsuite/ada/acats/tests/c3/c34005a.ada b/gcc-4.9/gcc/testsuite/ada/acats/tests/c3/c34005a.ada new file mode 100644 index 000000000..5da6fc939 --- /dev/null +++ b/gcc-4.9/gcc/testsuite/ada/acats/tests/c3/c34005a.ada @@ -0,0 +1,410 @@ +-- C34005A.ADA + +-- Grant of Unlimited Rights +-- +-- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687, +-- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained +-- unlimited rights in the software and documentation contained herein. +-- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making +-- this public release, the Government intends to confer upon all +-- recipients unlimited rights equal to those held by the Government. +-- These rights include rights to use, duplicate, release or disclose the +-- released technical data and computer software in whole or in part, in +-- any manner and for any purpose whatsoever, and to have or permit others +-- to do so. +-- +-- DISCLAIMER +-- +-- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR +-- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED +-- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF 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 REQUIRED PREDEFINED OPERATIONS ARE DECLARED +-- (IMPLICITLY) FOR DERIVED ONE-DIMENSIONAL ARRAY TYPES +-- WHOSE COMPONENT TYPE IS A NON-LIMITED, NON-DISCRETE TYPE. + +-- HISTORY: +-- JRK 9/10/86 CREATED ORIGINAL TEST. +-- PWN 01/31/95 REMOVED INCONSISTENCIES WITH ADA 9X. + +WITH SYSTEM; USE SYSTEM; +WITH REPORT; USE REPORT; + +PROCEDURE C34005A IS + + SUBTYPE COMPONENT IS FLOAT; + + PACKAGE PKG IS + + FIRST : CONSTANT := 0; + LAST : CONSTANT := 100; + + SUBTYPE INDEX IS INTEGER RANGE FIRST .. LAST; + + TYPE PARENT IS ARRAY (INDEX RANGE <>) OF COMPONENT; + + FUNCTION CREATE ( F, L : INDEX; + C : COMPONENT; + DUMMY : PARENT -- TO RESOLVE OVERLOADING. + ) RETURN PARENT; + + END PKG; + + USE PKG; + + TYPE T IS NEW PARENT (IDENT_INT (5) .. IDENT_INT (7)); + + TYPE ARRT IS ARRAY (INTEGER RANGE <>) OF COMPONENT; + SUBTYPE ARR IS ARRT (2 .. 4); + + X : T := (OTHERS => 2.0); + W : PARENT (5 .. 7) := (OTHERS => 2.0); + C : COMPONENT := 1.0; + B : BOOLEAN := FALSE; + U : ARR := (OTHERS => C); + N : CONSTANT := 1; + + PROCEDURE A (X : ADDRESS) IS + BEGIN + B := IDENT_BOOL (TRUE); + END A; + + FUNCTION V RETURN T IS + BEGIN + RETURN (OTHERS => C); + END V; + + PACKAGE BODY PKG IS + + FUNCTION CREATE + ( F, L : INDEX; + C : COMPONENT; + DUMMY : PARENT + ) RETURN PARENT + IS + A : PARENT (F .. L); + B : COMPONENT := C; + BEGIN + FOR I IN F .. L LOOP + A (I) := B; + B := B + 1.0; + END LOOP; + RETURN A; + END CREATE; + + END PKG; + + FUNCTION IDENT (X : T) RETURN T IS + BEGIN + IF EQUAL (X'LENGTH, X'LENGTH) THEN + RETURN X; -- ALWAYS EXECUTED. + END IF; + RETURN (OTHERS => -1.0); + END IDENT; + +BEGIN + TEST ("C34005A", "CHECK THAT THE REQUIRED PREDEFINED OPERATIONS " & + "ARE DECLARED (IMPLICITLY) FOR DERIVED " & + "ONE-DIMENSIONAL ARRAY TYPES WHOSE COMPONENT " & + "TYPE IS A NON-LIMITED, NON-DISCRETE TYPE"); + + X := IDENT ((1.0, 2.0, 3.0)); + IF X /= (1.0, 2.0, 3.0) THEN + FAILED ("INCORRECT :="); + END IF; + + IF T'(X) /= (1.0, 2.0, 3.0) THEN + FAILED ("INCORRECT QUALIFICATION"); + END IF; + + IF T (X) /= (1.0, 2.0, 3.0) THEN + FAILED ("INCORRECT SELF CONVERSION"); + END IF; + + IF EQUAL (3, 3) THEN + W := (1.0, 2.0, 3.0); + END IF; + IF T (W) /= (1.0, 2.0, 3.0) THEN + FAILED ("INCORRECT CONVERSION FROM PARENT"); + END IF; + + BEGIN + IF PARENT (X) /= (1.0, 2.0, 3.0) OR + PARENT (CREATE (2, 3, 4.0, X)) /= (4.0, 5.0) THEN + FAILED ("INCORRECT CONVERSION TO PARENT"); + END IF; + EXCEPTION + WHEN CONSTRAINT_ERROR => + FAILED ("CALL TO CREATE RAISED CONSTRAINT_ERROR - 1"); + WHEN OTHERS => + FAILED ("CALL TO CREATE RAISED EXCEPTION - 1"); + END; + + IF EQUAL (3, 3) THEN + U := (1.0, 2.0, 3.0); + END IF; + IF T (U) /= (1.0, 2.0, 3.0) THEN + FAILED ("INCORRECT CONVERSION FROM ARRAY"); + END IF; + + BEGIN + IF ARR (X) /= (1.0, 2.0, 3.0) OR + ARRT (CREATE (1, 2, 3.0, X)) /= (3.0, 4.0) THEN + FAILED ("INCORRECT CONVERSION TO ARRAY"); + END IF; + EXCEPTION + WHEN CONSTRAINT_ERROR => + FAILED ("CALL TO CREATE RAISED CONSTRAINT_ERROR - 2"); + WHEN OTHERS => + FAILED ("CALL TO CREATE RAISED EXCEPTION - 2"); + END; + + IF IDENT ((1.0, 2.0, 3.0)) /= (1.0, 2.0, 3.0) OR + X = (1.0, 2.0) THEN + FAILED ("INCORRECT AGGREGATE"); + END IF; + + BEGIN + IF X (IDENT_INT (5)) /= 1.0 OR + CREATE (2, 3, 4.0, X) (3) /= 5.0 THEN + FAILED ("INCORRECT INDEX (VALUE)"); + END IF; + EXCEPTION + WHEN CONSTRAINT_ERROR => + FAILED ("CALL TO CREATE RAISED CONSTRAINT_ERROR - 3"); + WHEN OTHERS => + FAILED ("CALL TO CREATE RAISED EXCEPTION - 3"); + END; + + X (IDENT_INT (7)) := 4.0; + IF X /= (1.0, 2.0, 4.0) THEN + FAILED ("INCORRECT INDEX (ASSIGNMENT)"); + END IF; + + BEGIN + X := IDENT ((1.0, 2.0, 3.0)); + IF X (IDENT_INT (6) .. IDENT_INT (7)) /= (2.0, 3.0) OR + CREATE (1, 4, 4.0, X) (1 .. 3) /= (4.0, 5.0, 6.0) THEN + FAILED ("INCORRECT SLICE (VALUE)"); + END IF; + EXCEPTION + WHEN CONSTRAINT_ERROR => + FAILED ("CALL TO CREATE RAISED CONSTRAINT_ERROR - 4"); + WHEN OTHERS => + FAILED ("CALL TO CREATE RAISED EXCEPTION - 4"); + END; + + X (IDENT_INT (5) .. IDENT_INT (6)) := (4.0, 5.0); + IF X /= (4.0, 5.0, 3.0) THEN + FAILED ("INCORRECT SLICE (ASSIGNMENT)"); + END IF; + + X := IDENT ((1.0, 2.0, 3.0)); + IF X = IDENT ((1.0, 2.0, 4.0)) OR X = (1.0, 2.0) THEN + FAILED ("INCORRECT ="); + END IF; + + IF X /= IDENT ((1.0, 2.0, 3.0)) OR NOT (X /= (2.0, 3.0)) THEN + FAILED ("INCORRECT /="); + END IF; + + IF NOT (X IN T) OR (1.0, 2.0) IN T THEN + FAILED ("INCORRECT ""IN"""); + END IF; + + IF X NOT IN T OR NOT ((1.0, 2.0) NOT IN T) THEN + FAILED ("INCORRECT ""NOT IN"""); + END IF; + + BEGIN + IF X & (4.0, 5.0, 6.0) /= (1.0, 2.0, 3.0, 4.0, 5.0, 6.0) OR + CREATE (2, 3, 2.0, X) & (4.0, 5.0) /= + (2.0, 3.0, 4.0, 5.0) THEN + FAILED ("INCORRECT & (ARRAY, ARRAY)"); + END IF; + EXCEPTION + WHEN CONSTRAINT_ERROR => + FAILED ("CALL TO CREATE RAISED CONSTRAINT_ERROR - 5"); + WHEN OTHERS => + FAILED ("CALL TO CREATE RAISED EXCEPTION - 5"); + END; + + BEGIN + IF X & 4.0 /= (1.0, 2.0, 3.0, 4.0) OR + CREATE (2, 3, 2.0, X) & 4.0 /= (2.0, 3.0, 4.0) THEN + FAILED ("INCORRECT & (ARRAY, COMPONENT)"); + END IF; + EXCEPTION + WHEN CONSTRAINT_ERROR => + FAILED ("CALL TO CREATE RAISED CONSTRAINT_ERROR - 6"); + WHEN OTHERS => + FAILED ("CALL TO CREATE RAISED EXCEPTION - 6"); + END; + + BEGIN + IF 4.0 & X /= (4.0, 1.0, 2.0, 3.0) OR + 2.0 & CREATE (2, 3, 3.0, X) /= (2.0, 3.0, 4.0) THEN + FAILED ("INCORRECT & (COMPONENT, ARRAY)"); + END IF; + EXCEPTION + WHEN CONSTRAINT_ERROR => + FAILED ("CALL TO CREATE RAISED CONSTRAINT_ERROR - 7"); + WHEN OTHERS => + FAILED ("CALL TO CREATE RAISED EXCEPTION - 7"); + END; + + IF EQUAL (3, 3) THEN + C := 2.0; + END IF; + + BEGIN + IF C & 3.0 /= CREATE (2, 3, 2.0, X) THEN + FAILED ("INCORRECT & (COMPONENT, COMPONENT)"); + END IF; + EXCEPTION + WHEN CONSTRAINT_ERROR => + FAILED ("CALL TO CREATE RAISED CONSTRAINT_ERROR - 8"); + WHEN OTHERS => + FAILED ("CALL TO CREATE RAISED EXCEPTION - 8"); + END; + + B := FALSE; + A (X'ADDRESS); + IF NOT B THEN + FAILED ("INCORRECT 'ADDRESS"); + END IF; + + IF T'FIRST /= 5 THEN + FAILED ("INCORRECT TYPE'FIRST"); + END IF; + + IF X'FIRST /= 5 THEN + FAILED ("INCORRECT OBJECT'FIRST"); + END IF; + + IF V'FIRST /= 5 THEN + FAILED ("INCORRECT VALUE'FIRST"); + END IF; + + IF T'FIRST (N) /= 5 THEN + FAILED ("INCORRECT TYPE'FIRST (N)"); + END IF; + + IF X'FIRST (N) /= 5 THEN + FAILED ("INCORRECT OBJECT'FIRST (N)"); + END IF; + + IF V'FIRST (N) /= 5 THEN + FAILED ("INCORRECT VALUE'FIRST (N)"); + END IF; + + IF T'LAST /= 7 THEN + FAILED ("INCORRECT TYPE'LAST"); + END IF; + + IF X'LAST /= 7 THEN + FAILED ("INCORRECT OBJECT'LAST"); + END IF; + + IF V'LAST /= 7 THEN + FAILED ("INCORRECT VALUE'LAST"); + END IF; + + IF T'LAST (N) /= 7 THEN + FAILED ("INCORRECT TYPE'LAST (N)"); + END IF; + + IF X'LAST (N) /= 7 THEN + FAILED ("INCORRECT OBJECT'LAST (N)"); + END IF; + + IF V'LAST (N) /= 7 THEN + FAILED ("INCORRECT VALUE'LAST (N)"); + END IF; + + IF T'LENGTH /= 3 THEN + FAILED ("INCORRECT TYPE'LENGTH"); + END IF; + + IF X'LENGTH /= 3 THEN + FAILED ("INCORRECT OBJECT'LENGTH"); + END IF; + + IF V'LENGTH /= 3 THEN + FAILED ("INCORRECT VALUE'LENGTH"); + END IF; + + IF T'LENGTH (N) /= 3 THEN + FAILED ("INCORRECT TYPE'LENGTH (N)"); + END IF; + + IF X'LENGTH (N) /= 3 THEN + FAILED ("INCORRECT OBJECT'LENGTH (N)"); + END IF; + + IF V'LENGTH (N) /= 3 THEN + FAILED ("INCORRECT VALUE'LENGTH (N)"); + END IF; + + DECLARE + Y : PARENT (T'RANGE); + BEGIN + IF Y'FIRST /= 5 OR Y'LAST /= 7 THEN + FAILED ("INCORRECT TYPE'RANGE"); + END IF; + END; + + DECLARE + Y : PARENT (X'RANGE); + BEGIN + IF Y'FIRST /= 5 OR Y'LAST /= 7 THEN + FAILED ("INCORRECT OBJECT'RANGE"); + END IF; + END; + + DECLARE + Y : PARENT (V'RANGE); + BEGIN + IF Y'FIRST /= 5 OR Y'LAST /= 7 THEN + FAILED ("INCORRECT VALUE'RANGE"); + END IF; + END; + + DECLARE + Y : PARENT (T'RANGE (N)); + BEGIN + IF Y'FIRST /= 5 OR Y'LAST /= 7 THEN + FAILED ("INCORRECT TYPE'RANGE (N)"); + END IF; + END; + + DECLARE + Y : PARENT (X'RANGE (N)); + BEGIN + IF Y'FIRST /= 5 OR Y'LAST /= 7 THEN + FAILED ("INCORRECT OBJECT'RANGE (N)"); + END IF; + END; + + DECLARE + Y : PARENT (V'RANGE (N)); + BEGIN + IF Y'FIRST /= 5 OR Y'LAST /= 7 THEN + FAILED ("INCORRECT VALUE'RANGE (N)"); + END IF; + END; + + IF T'SIZE < T'LENGTH * COMPONENT'SIZE THEN + FAILED ("INCORRECT TYPE'SIZE"); + END IF; + + IF X'SIZE < X'LENGTH * COMPONENT'SIZE THEN + FAILED ("INCORRECT OBJECT'SIZE"); + END IF; + + RESULT; +END C34005A; diff --git a/gcc-4.9/gcc/testsuite/ada/acats/tests/c3/c34005c.ada b/gcc-4.9/gcc/testsuite/ada/acats/tests/c3/c34005c.ada new file mode 100644 index 000000000..2af86afe1 --- /dev/null +++ b/gcc-4.9/gcc/testsuite/ada/acats/tests/c3/c34005c.ada @@ -0,0 +1,195 @@ +-- C34005C.ADA + +-- Grant of Unlimited Rights +-- +-- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687, +-- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained +-- unlimited rights in the software and documentation contained herein. +-- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making +-- this public release, the Government intends to confer upon all +-- recipients unlimited rights equal to those held by the Government. +-- These rights include rights to use, duplicate, release or disclose the +-- released technical data and computer software in whole or in part, in +-- any manner and for any purpose whatsoever, and to have or permit others +-- to do so. +-- +-- DISCLAIMER +-- +-- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR +-- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED +-- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE +-- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE +-- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A +-- PARTICULAR PURPOSE OF SAID MATERIAL. +--* +-- OBJECTIVE: +-- FOR DERIVED ONE-DIMENSIONAL ARRAY TYPES WHOSE COMPONENT TYPE IS A +-- NON-LIMITED, NON-DISCRETE TYPE: +-- CHECK THAT ALL VALUES OF THE PARENT (BASE) TYPE ARE PRESENT FOR +-- THE DERIVED (BASE) TYPE WHEN THE DERIVED TYPE DEFINITION IS +-- CONSTRAINED. +-- CHECK THAT ANY CONSTRAINT IMPOSED ON THE PARENT SUBTYPE IS ALSO +-- IMPOSED ON THE DERIVED SUBTYPE. + +-- HISTORY: +-- JRK 9/10/86 CREATED ORIGINAL TEST. + +WITH REPORT; USE REPORT; + +PROCEDURE C34005C IS + + SUBTYPE COMPONENT IS FLOAT; + + PACKAGE PKG IS + + FIRST : CONSTANT := 0; + LAST : CONSTANT := 100; + + SUBTYPE INDEX IS INTEGER RANGE FIRST .. LAST; + + TYPE PARENT IS ARRAY (INDEX RANGE <>) OF COMPONENT; + + FUNCTION CREATE ( F, L : INDEX; + C : COMPONENT; + DUMMY : PARENT -- TO RESOLVE OVERLOADING. + ) RETURN PARENT; + + END PKG; + + USE PKG; + + TYPE T IS NEW PARENT (IDENT_INT (5) .. IDENT_INT (7)); + + SUBTYPE SUBPARENT IS PARENT (5 .. 7); + + TYPE S IS NEW SUBPARENT; + + X : T := (OTHERS => 2.0); + Y : S := (OTHERS => 2.0); + + PACKAGE BODY PKG IS + + FUNCTION CREATE + ( F, L : INDEX; + C : COMPONENT; + DUMMY : PARENT + ) RETURN PARENT + IS + A : PARENT (F .. L); + B : COMPONENT := C; + BEGIN + FOR I IN F .. L LOOP + A (I) := B; + B := B + 1.0; + END LOOP; + RETURN A; + END CREATE; + + END PKG; + +BEGIN + TEST ("C34005C", "CHECK THAT ALL VALUES OF THE PARENT (BASE) " & + "TYPE ARE PRESENT FOR THE DERIVED (BASE) TYPE " & + "WHEN THE DERIVED TYPE DEFINITION IS " & + "CONSTRAINED. ALSO CHECK THAT ANY CONSTRAINT " & + "IMPOSED ON THE PARENT SUBTYPE IS ALSO IMPOSED " & + "ON THE DERIVED SUBTYPE. CHECK FOR DERIVED " & + "ONE-DIMENSIONAL ARRAY TYPES WHOSE COMPONENT " & + "TYPE IS A NON-LIMITED, NON-DISCRETE TYPE"); + + -- CHECK THAT BASE TYPE VALUES NOT IN THE SUBTYPE ARE PRESENT. + + BEGIN + IF CREATE (2, 3, 4.0, X) /= (4.0, 5.0) OR + CREATE (2, 3, 4.0, Y) /= (4.0, 5.0) THEN + FAILED ("CAN'T CREATE BASE TYPE VALUES OUTSIDE THE " & + "SUBTYPE"); + END IF; + EXCEPTION + WHEN CONSTRAINT_ERROR => + FAILED ("CALL TO CREATE RAISED CONSTRAINT_ERROR"); + WHEN OTHERS => + FAILED ("CALL TO CREATE RAISED EXCEPTION"); + END; + + IF X & (3.0, 4.0) /= (2.0, 2.0, 2.0, 3.0, 4.0) OR + Y & (3.0, 4.0) /= (2.0, 2.0, 2.0, 3.0, 4.0) THEN + FAILED ("INCORRECT &"); + END IF; + + -- CHECK THE DERIVED SUBTYPE CONSTRAINT. + + IF T'FIRST /= 5 OR T'LAST /= 7 OR + S'FIRST /= 5 OR S'LAST /= 7 THEN + FAILED ("INCORRECT 'FIRST OR 'LAST"); + END IF; + + BEGIN + X := (1.0, 2.0, 3.0); + Y := (1.0, 2.0, 3.0); + IF PARENT (X) /= PARENT (Y) THEN -- USE X AND Y. + FAILED ("INCORRECT CONVERSION TO PARENT"); + END IF; + EXCEPTION + WHEN OTHERS => + FAILED ("EXCEPTION RAISED BY OK ASSIGNMENT"); + END; + + BEGIN + X := (1.0, 2.0); + FAILED ("CONSTRAINT_ERROR NOT RAISED -- X := (1.0, 2.0)"); + IF X = (1.0, 2.0) THEN -- USE X. + COMMENT ("X ALTERED -- X := (1.0, 2.0)"); + END IF; + EXCEPTION + WHEN CONSTRAINT_ERROR => + NULL; + WHEN OTHERS => + FAILED ("WRONG EXCEPTION RAISED -- X := (1.0, 2.0)"); + END; + + BEGIN + X := (1.0, 2.0, 3.0, 4.0); + FAILED ("CONSTRAINT_ERROR NOT RAISED -- " & + "X := (1.0, 2.0, 3.0, 4.0)"); + IF X = (1.0, 2.0, 3.0, 4.0) THEN -- USE X. + COMMENT ("X ALTERED -- X := (1.0, 2.0, 3.0, 4.0)"); + END IF; + EXCEPTION + WHEN CONSTRAINT_ERROR => + NULL; + WHEN OTHERS => + FAILED ("WRONG EXCEPTION RAISED -- " & + "X := (1.0, 2.0, 3.0, 4.0)"); + END; + + BEGIN + Y := (1.0, 2.0); + FAILED ("CONSTRAINT_ERROR NOT RAISED -- Y := (1.0, 2.0)"); + IF Y = (1.0, 2.0) THEN -- USE Y. + COMMENT ("Y ALTERED -- Y := (1.0, 2.0)"); + END IF; + EXCEPTION + WHEN CONSTRAINT_ERROR => + NULL; + WHEN OTHERS => + FAILED ("WRONG EXCEPTION RAISED -- Y := (1.0, 2.0)"); + END; + + BEGIN + Y := (1.0, 2.0, 3.0, 4.0); + FAILED ("CONSTRAINT_ERROR NOT RAISED -- " & + "Y := (1.0, 2.0, 3.0, 4.0)"); + IF Y = (1.0, 2.0, 3.0, 4.0) THEN -- USE Y. + COMMENT ("Y ALTERED -- Y := (1.0, 2.0, 3.0, 4.0)"); + END IF; + EXCEPTION + WHEN CONSTRAINT_ERROR => + NULL; + WHEN OTHERS => + FAILED ("WRONG EXCEPTION RAISED -- " & + "Y := (1.0, 2.0, 3.0, 4.0)"); + END; + + RESULT; +END C34005C; diff --git a/gcc-4.9/gcc/testsuite/ada/acats/tests/c3/c34005d.ada b/gcc-4.9/gcc/testsuite/ada/acats/tests/c3/c34005d.ada new file mode 100644 index 000000000..b549be35d --- /dev/null +++ b/gcc-4.9/gcc/testsuite/ada/acats/tests/c3/c34005d.ada @@ -0,0 +1,425 @@ +-- C34005D.ADA + +-- Grant of Unlimited Rights +-- +-- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687, +-- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained +-- unlimited rights in the software and documentation contained herein. +-- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making +-- this public release, the Government intends to confer upon all +-- recipients unlimited rights equal to those held by the Government. +-- These rights include rights to use, duplicate, release or disclose the +-- released technical data and computer software in whole or in part, in +-- any manner and for any purpose whatsoever, and to have or permit others +-- to do so. +-- +-- DISCLAIMER +-- +-- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR +-- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED +-- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF 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 REQUIRED PREDEFINED OPERATIONS ARE DECLARED +-- (IMPLICITLY) FOR DERIVED ONE-DIMENSIONAL ARRAY TYPES +-- WHOSE COMPONENT TYPE IS A DISCRETE TYPE. + +-- HISTORY: +-- JRK 9/12/86 CREATED ORIGINAL TEST. +-- PWN 11/30/94 REMOVED 'BASE USE ILLEGAL IN ADA 9X. + +WITH SYSTEM; USE SYSTEM; +WITH REPORT; USE REPORT; + +PROCEDURE C34005D IS + + SUBTYPE COMPONENT IS INTEGER; + + PACKAGE PKG IS + + FIRST : CONSTANT := 0; + LAST : CONSTANT := 100; + + SUBTYPE INDEX IS INTEGER RANGE FIRST .. LAST; + + TYPE PARENT IS ARRAY (INDEX RANGE <>) OF COMPONENT; + + FUNCTION CREATE ( F, L : INDEX; + C : COMPONENT; + DUMMY : PARENT -- TO RESOLVE OVERLOADING. + ) RETURN PARENT; + + END PKG; + + USE PKG; + + TYPE T IS NEW PARENT (IDENT_INT (5) .. IDENT_INT (7)); + + TYPE ARRT IS ARRAY (INTEGER RANGE <>) OF COMPONENT; + SUBTYPE ARR IS ARRT (2 .. 4); + + X : T := (OTHERS => 2); + W : PARENT (5 .. 7) := (OTHERS => 2); + C : COMPONENT := 1; + B : BOOLEAN := FALSE; + U : ARR := (OTHERS => C); + N : CONSTANT := 1; + + PROCEDURE A (X : ADDRESS) IS + BEGIN + B := IDENT_BOOL (TRUE); + END A; + + FUNCTION V RETURN T IS + BEGIN + RETURN (OTHERS => C); + END V; + + PACKAGE BODY PKG IS + + FUNCTION CREATE + ( F, L : INDEX; + C : COMPONENT; + DUMMY : PARENT + ) RETURN PARENT + IS + A : PARENT (F .. L); + B : COMPONENT := C; + BEGIN + FOR I IN F .. L LOOP + A (I) := B; + B := B + 1; + END LOOP; + RETURN A; + END CREATE; + + END PKG; + + FUNCTION IDENT (X : T) RETURN T IS + BEGIN + IF EQUAL (X'LENGTH, X'LENGTH) THEN + RETURN X; -- ALWAYS EXECUTED. + END IF; + RETURN (OTHERS => -1); + END IDENT; + +BEGIN + TEST ("C34005D", "CHECK THAT THE REQUIRED PREDEFINED OPERATIONS " & + "ARE DECLARED (IMPLICITLY) FOR DERIVED " & + "ONE-DIMENSIONAL ARRAY TYPES WHOSE COMPONENT " & + "TYPE IS A DISCRETE TYPE"); + + X := IDENT ((1, 2, 3)); + IF X /= (1, 2, 3) THEN + FAILED ("INCORRECT :="); + END IF; + + IF T'(X) /= (1, 2, 3) THEN + FAILED ("INCORRECT QUALIFICATION"); + END IF; + + IF T (X) /= (1, 2, 3) THEN + FAILED ("INCORRECT SELF CONVERSION"); + END IF; + + IF EQUAL (3, 3) THEN + W := (1, 2, 3); + END IF; + IF T (W) /= (1, 2, 3) THEN + FAILED ("INCORRECT CONVERSION FROM PARENT"); + END IF; + + BEGIN + IF PARENT (X) /= (1, 2, 3) OR + PARENT (CREATE (2, 3, 4, X)) /= (4, 5) THEN + FAILED ("INCORRECT CONVERSION TO PARENT"); + END IF; + EXCEPTION + WHEN CONSTRAINT_ERROR => + FAILED ("CALL TO CREATE RAISED CONSTRAINT_ERROR - 1"); + WHEN OTHERS => + FAILED ("CALL TO CREATE RAISED EXCEPTION - 1"); + END; + + IF EQUAL (3, 3) THEN + U := (1, 2, 3); + END IF; + IF T (U) /= (1, 2, 3) THEN + FAILED ("INCORRECT CONVERSION FROM ARRAY"); + END IF; + + BEGIN + IF ARR (X) /= (1, 2, 3) OR + ARRT (CREATE (1, 2, 3, X)) /= (3, 4) THEN + FAILED ("INCORRECT CONVERSION TO ARRAY"); + END IF; + EXCEPTION + WHEN CONSTRAINT_ERROR => + FAILED ("CALL TO CREATE RAISED CONSTRAINT_ERROR - 2"); + WHEN OTHERS => + FAILED ("CALL TO CREATE RAISED EXCEPTION - 2"); + END; + + IF IDENT ((1, 2, 3)) /= (1, 2, 3) OR + X = (1, 2) THEN + FAILED ("INCORRECT AGGREGATE"); + END IF; + + BEGIN + IF X (IDENT_INT (5)) /= 1 OR + CREATE (2, 3, 4, X) (3) /= 5 THEN + FAILED ("INCORRECT INDEX (VALUE)"); + END IF; + EXCEPTION + WHEN CONSTRAINT_ERROR => + FAILED ("CALL TO CREATE RAISED CONSTRAINT_ERROR - 3"); + WHEN OTHERS => + FAILED ("CALL TO CREATE RAISED EXCEPTION - 3"); + END; + + X (IDENT_INT (7)) := 4; + IF X /= (1, 2, 4) THEN + FAILED ("INCORRECT INDEX (ASSIGNMENT)"); + END IF; + + BEGIN + X := IDENT ((1, 2, 3)); + IF X (IDENT_INT (6) .. IDENT_INT (7)) /= (2, 3) OR + CREATE (1, 4, 4, X) (1 .. 3) /= (4, 5, 6) THEN + FAILED ("INCORRECT SLICE (VALUE)"); + END IF; + EXCEPTION + WHEN CONSTRAINT_ERROR => + FAILED ("CALL TO CREATE RAISED CONSTRAINT_ERROR - 4"); + WHEN OTHERS => + FAILED ("CALL TO CREATE RAISED EXCEPTION - 4"); + END; + + X (IDENT_INT (5) .. IDENT_INT (6)) := (4, 5); + IF X /= (4, 5, 3) THEN + FAILED ("INCORRECT SLICE (ASSIGNMENT)"); + END IF; + + X := IDENT ((1, 2, 3)); + IF X = IDENT ((1, 2, 4)) OR X = (1, 2) THEN + FAILED ("INCORRECT ="); + END IF; + + IF X /= IDENT ((1, 2, 3)) OR NOT (X /= (2, 3)) THEN + FAILED ("INCORRECT /="); + END IF; + + IF X < IDENT ((1, 2, 3)) OR X < (1, 2) THEN + FAILED ("INCORRECT <"); + END IF; + + IF X > IDENT ((1, 2, 3)) OR X > (1, 3) THEN + FAILED ("INCORRECT >"); + END IF; + + IF X <= IDENT ((1, 2, 2)) OR X <= (1, 2, 2, 4) THEN + FAILED ("INCORRECT <="); + END IF; + + IF X >= IDENT ((1, 2, 4)) OR X >= (1, 2, 3, 1) THEN + FAILED ("INCORRECT >="); + END IF; + + IF NOT (X IN T) OR (1, 2) IN T THEN + FAILED ("INCORRECT ""IN"""); + END IF; + + IF X NOT IN T OR NOT ((1, 2) NOT IN T) THEN + FAILED ("INCORRECT ""NOT IN"""); + END IF; + + BEGIN + IF X & (4, 5, 6) /= (1, 2, 3, 4, 5, 6) OR + CREATE (2, 3, 2, X) & (4, 5) /= (2, 3, 4, 5) THEN + FAILED ("INCORRECT & (ARRAY, ARRAY)"); + END IF; + EXCEPTION + WHEN CONSTRAINT_ERROR => + FAILED ("CALL TO CREATE RAISED CONSTRAINT_ERROR - 5"); + WHEN OTHERS => + FAILED ("CALL TO CREATE RAISED EXCEPTION - 5"); + END; + + BEGIN + IF X & 4 /= (1, 2, 3, 4) OR + CREATE (2, 3, 2, X) & 4 /= (2, 3, 4) THEN + FAILED ("INCORRECT & (ARRAY, COMPONENT)"); + END IF; + EXCEPTION + WHEN CONSTRAINT_ERROR => + FAILED ("CALL TO CREATE RAISED CONSTRAINT_ERROR - 6"); + WHEN OTHERS => + FAILED ("CALL TO CREATE RAISED EXCEPTION - 6"); + END; + + BEGIN + IF 4 & X /= (4, 1, 2, 3) OR + 2 & CREATE (2, 3, 3, X) /= (2, 3, 4) THEN + FAILED ("INCORRECT & (COMPONENT, ARRAY)"); + END IF; + EXCEPTION + WHEN CONSTRAINT_ERROR => + FAILED ("CALL TO CREATE RAISED CONSTRAINT_ERROR - 7"); + WHEN OTHERS => + FAILED ("CALL TO CREATE RAISED EXCEPTION - 7"); + END; + + IF EQUAL (3, 3) THEN + C := 2; + END IF; + + BEGIN + IF C & 3 /= CREATE (2, 3, 2, X) THEN + FAILED ("INCORRECT & (COMPONENT, COMPONENT)"); + END IF; + EXCEPTION + WHEN CONSTRAINT_ERROR => + FAILED ("CALL TO CREATE RAISED CONSTRAINT_ERROR - 8"); + WHEN OTHERS => + FAILED ("CALL TO CREATE RAISED EXCEPTION - 8"); + END; + + B := FALSE; + A (X'ADDRESS); + IF NOT B THEN + FAILED ("INCORRECT 'ADDRESS"); + END IF; + + IF T'FIRST /= 5 THEN + FAILED ("INCORRECT TYPE'FIRST"); + END IF; + + IF X'FIRST /= 5 THEN + FAILED ("INCORRECT OBJECT'FIRST"); + END IF; + + IF V'FIRST /= 5 THEN + FAILED ("INCORRECT VALUE'FIRST"); + END IF; + + IF T'FIRST (N) /= 5 THEN + FAILED ("INCORRECT TYPE'FIRST (N)"); + END IF; + + IF X'FIRST (N) /= 5 THEN + FAILED ("INCORRECT OBJECT'FIRST (N)"); + END IF; + + IF V'FIRST (N) /= 5 THEN + FAILED ("INCORRECT VALUE'FIRST (N)"); + END IF; + + IF T'LAST /= 7 THEN + FAILED ("INCORRECT TYPE'LAST"); + END IF; + + IF X'LAST /= 7 THEN + FAILED ("INCORRECT OBJECT'LAST"); + END IF; + + IF V'LAST /= 7 THEN + FAILED ("INCORRECT VALUE'LAST"); + END IF; + + IF T'LAST (N) /= 7 THEN + FAILED ("INCORRECT TYPE'LAST (N)"); + END IF; + + IF X'LAST (N) /= 7 THEN + FAILED ("INCORRECT OBJECT'LAST (N)"); + END IF; + + IF V'LAST (N) /= 7 THEN + FAILED ("INCORRECT VALUE'LAST (N)"); + END IF; + + IF T'LENGTH /= 3 THEN + FAILED ("INCORRECT TYPE'LENGTH"); + END IF; + + IF X'LENGTH /= 3 THEN + FAILED ("INCORRECT OBJECT'LENGTH"); + END IF; + + IF V'LENGTH /= 3 THEN + FAILED ("INCORRECT VALUE'LENGTH"); + END IF; + + IF T'LENGTH (N) /= 3 THEN + FAILED ("INCORRECT TYPE'LENGTH (N)"); + END IF; + + IF X'LENGTH (N) /= 3 THEN + FAILED ("INCORRECT OBJECT'LENGTH (N)"); + END IF; + + IF V'LENGTH (N) /= 3 THEN + FAILED ("INCORRECT VALUE'LENGTH (N)"); + END IF; + + DECLARE + Y : PARENT (T'RANGE); + BEGIN + IF Y'FIRST /= 5 OR Y'LAST /= 7 THEN + FAILED ("INCORRECT TYPE'RANGE"); + END IF; + END; + + DECLARE + Y : PARENT (X'RANGE); + BEGIN + IF Y'FIRST /= 5 OR Y'LAST /= 7 THEN + FAILED ("INCORRECT OBJECT'RANGE"); + END IF; + END; + + DECLARE + Y : PARENT (V'RANGE); + BEGIN + IF Y'FIRST /= 5 OR Y'LAST /= 7 THEN + FAILED ("INCORRECT VALUE'RANGE"); + END IF; + END; + + DECLARE + Y : PARENT (T'RANGE (N)); + BEGIN + IF Y'FIRST /= 5 OR Y'LAST /= 7 THEN + FAILED ("INCORRECT TYPE'RANGE (N)"); + END IF; + END; + + DECLARE + Y : PARENT (X'RANGE (N)); + BEGIN + IF Y'FIRST /= 5 OR Y'LAST /= 7 THEN + FAILED ("INCORRECT OBJECT'RANGE (N)"); + END IF; + END; + + DECLARE + Y : PARENT (V'RANGE (N)); + BEGIN + IF Y'FIRST /= 5 OR Y'LAST /= 7 THEN + FAILED ("INCORRECT VALUE'RANGE (N)"); + END IF; + END; + + IF T'SIZE < T'LENGTH * COMPONENT'SIZE THEN + FAILED ("INCORRECT TYPE'SIZE"); + END IF; + + IF X'SIZE < X'LENGTH * COMPONENT'SIZE THEN + FAILED ("INCORRECT OBJECT'SIZE"); + END IF; + + RESULT; +END C34005D; diff --git a/gcc-4.9/gcc/testsuite/ada/acats/tests/c3/c34005f.ada b/gcc-4.9/gcc/testsuite/ada/acats/tests/c3/c34005f.ada new file mode 100644 index 000000000..1971bf4e8 --- /dev/null +++ b/gcc-4.9/gcc/testsuite/ada/acats/tests/c3/c34005f.ada @@ -0,0 +1,195 @@ +-- C34005F.ADA + +-- Grant of Unlimited Rights +-- +-- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687, +-- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained +-- unlimited rights in the software and documentation contained herein. +-- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making +-- this public release, the Government intends to confer upon all +-- recipients unlimited rights equal to those held by the Government. +-- These rights include rights to use, duplicate, release or disclose the +-- released technical data and computer software in whole or in part, in +-- any manner and for any purpose whatsoever, and to have or permit others +-- to do so. +-- +-- DISCLAIMER +-- +-- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR +-- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED +-- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE +-- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE +-- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A +-- PARTICULAR PURPOSE OF SAID MATERIAL. +--* +-- OBJECTIVE: +-- FOR DERIVED ONE-DIMENSIONAL ARRAY TYPES WHOSE COMPONENT TYPE IS A +-- DISCRETE TYPE: +-- CHECK THAT ALL VALUES OF THE PARENT (BASE) TYPE ARE PRESENT FOR +-- THE DERIVED (BASE) TYPE WHEN THE DERIVED TYPE DEFINITION IS +-- CONSTRAINED. +-- CHECK THAT ANY CONSTRAINT IMPOSED ON THE PARENT SUBTYPE IS ALSO +-- IMPOSED ON THE DERIVED SUBTYPE. + +-- HISTORY: +-- JRK 9/12/86 CREATED ORIGINAL TEST. + +WITH REPORT; USE REPORT; + +PROCEDURE C34005F IS + + SUBTYPE COMPONENT IS INTEGER; + + PACKAGE PKG IS + + FIRST : CONSTANT := 0; + LAST : CONSTANT := 100; + + SUBTYPE INDEX IS INTEGER RANGE FIRST .. LAST; + + TYPE PARENT IS ARRAY (INDEX RANGE <>) OF COMPONENT; + + FUNCTION CREATE ( F, L : INDEX; + C : COMPONENT; + DUMMY : PARENT -- TO RESOLVE OVERLOADING. + ) RETURN PARENT; + + END PKG; + + USE PKG; + + TYPE T IS NEW PARENT (IDENT_INT (5) .. IDENT_INT (7)); + + SUBTYPE SUBPARENT IS PARENT (5 .. 7); + + TYPE S IS NEW SUBPARENT; + + X : T := (OTHERS => 2); + Y : S := (OTHERS => 2); + + PACKAGE BODY PKG IS + + FUNCTION CREATE + ( F, L : INDEX; + C : COMPONENT; + DUMMY : PARENT + ) RETURN PARENT + IS + A : PARENT (F .. L); + B : COMPONENT := C; + BEGIN + FOR I IN F .. L LOOP + A (I) := B; + B := B + 1; + END LOOP; + RETURN A; + END CREATE; + + END PKG; + +BEGIN + TEST ("C34005F", "CHECK THAT ALL VALUES OF THE PARENT (BASE) " & + "TYPE ARE PRESENT FOR THE DERIVED (BASE) TYPE " & + "WHEN THE DERIVED TYPE DEFINITION IS " & + "CONSTRAINED. ALSO CHECK THAT ANY CONSTRAINT " & + "IMPOSED ON THE PARENT SUBTYPE IS ALSO IMPOSED " & + "ON THE DERIVED SUBTYPE. CHECK FOR DERIVED " & + "ONE-DIMENSIONAL ARRAY TYPES WHOSE COMPONENT " & + "TYPE IS A DISCRETE TYPE"); + + -- CHECK THAT BASE TYPE VALUES NOT IN THE SUBTYPE ARE PRESENT. + + BEGIN + IF CREATE (2, 3, 4, X) /= (4, 5) OR + CREATE (2, 3, 4, Y) /= (4, 5) THEN + FAILED ("CAN'T CREATE BASE TYPE VALUES OUTSIDE THE " & + "SUBTYPE"); + END IF; + EXCEPTION + WHEN CONSTRAINT_ERROR => + FAILED ("CALL TO CREATE RAISED CONSTRAINT_ERROR"); + WHEN OTHERS => + FAILED ("CALL TO CREATE RAISED EXCEPTION"); + END; + + IF X & (3, 4) /= (2, 2, 2, 3, 4) OR + Y & (3, 4) /= (2, 2, 2, 3, 4) THEN + FAILED ("INCORRECT &"); + END IF; + + -- CHECK THE DERIVED SUBTYPE CONSTRAINT. + + IF T'FIRST /= 5 OR T'LAST /= 7 OR + S'FIRST /= 5 OR S'LAST /= 7 THEN + FAILED ("INCORRECT 'FIRST OR 'LAST"); + END IF; + + BEGIN + X := (1, 2, 3); + Y := (1, 2, 3); + IF PARENT (X) /= PARENT (Y) THEN -- USE X AND Y. + FAILED ("INCORRECT CONVERSION TO PARENT"); + END IF; + EXCEPTION + WHEN OTHERS => + FAILED ("EXCEPTION RAISED BY OK ASSIGNMENT"); + END; + + BEGIN + X := (1, 2); + FAILED ("CONSTRAINT_ERROR NOT RAISED -- X := (1, 2)"); + IF X = (1, 2) THEN -- USE X. + COMMENT ("X ALTERED -- X := (1, 2)"); + END IF; + EXCEPTION + WHEN CONSTRAINT_ERROR => + NULL; + WHEN OTHERS => + FAILED ("WRONG EXCEPTION RAISED -- X := (1, 2)"); + END; + + BEGIN + X := (1, 2, 3, 4); + FAILED ("CONSTRAINT_ERROR NOT RAISED -- " & + "X := (1, 2, 3, 4)"); + IF X = (1, 2, 3, 4) THEN -- USE X. + COMMENT ("X ALTERED -- X := (1, 2, 3, 4)"); + END IF; + EXCEPTION + WHEN CONSTRAINT_ERROR => + NULL; + WHEN OTHERS => + FAILED ("WRONG EXCEPTION RAISED -- " & + "X := (1, 2, 3, 4)"); + END; + + BEGIN + Y := (1, 2); + FAILED ("CONSTRAINT_ERROR NOT RAISED -- Y := (1, 2)"); + IF Y = (1, 2) THEN -- USE Y. + COMMENT ("Y ALTERED -- Y := (1, 2)"); + END IF; + EXCEPTION + WHEN CONSTRAINT_ERROR => + NULL; + WHEN OTHERS => + FAILED ("WRONG EXCEPTION RAISED -- Y := (1, 2)"); + END; + + BEGIN + Y := (1, 2, 3, 4); + FAILED ("CONSTRAINT_ERROR NOT RAISED -- " & + "Y := (1, 2, 3, 4)"); + IF Y = (1, 2, 3, 4) THEN -- USE Y. + COMMENT ("Y ALTERED -- Y := (1, 2, 3, 4)"); + END IF; + EXCEPTION + WHEN CONSTRAINT_ERROR => + NULL; + WHEN OTHERS => + FAILED ("WRONG EXCEPTION RAISED -- " & + "Y := (1, 2, 3, 4)"); + END; + + RESULT; +END C34005F; diff --git a/gcc-4.9/gcc/testsuite/ada/acats/tests/c3/c34005g.ada b/gcc-4.9/gcc/testsuite/ada/acats/tests/c3/c34005g.ada new file mode 100644 index 000000000..fd8f8ffbf --- /dev/null +++ b/gcc-4.9/gcc/testsuite/ada/acats/tests/c3/c34005g.ada @@ -0,0 +1,423 @@ +-- C34005G.ADA + +-- Grant of Unlimited Rights +-- +-- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687, +-- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained +-- unlimited rights in the software and documentation contained herein. +-- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making +-- this public release, the Government intends to confer upon all +-- recipients unlimited rights equal to those held by the Government. +-- These rights include rights to use, duplicate, release or disclose the +-- released technical data and computer software in whole or in part, in +-- any manner and for any purpose whatsoever, and to have or permit others +-- to do so. +-- +-- DISCLAIMER +-- +-- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR +-- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED +-- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF 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 REQUIRED PREDEFINED OPERATIONS ARE DECLARED +-- (IMPLICITLY) FOR DERIVED ONE-DIMENSIONAL ARRAY TYPES +-- WHOSE COMPONENT TYPE IS A CHARACTER TYPE. + +-- HISTORY: +-- JRK 9/15/86 CREATED ORIGINAL TEST. +-- RJW 8/21/89 MODIFIED CHECKS FOR OBJECT AND TYPE SIZES. +-- PWN 01/31/95 REMOVED INCONSISTENCIES WITH ADA 9X. + +WITH SYSTEM; USE SYSTEM; +WITH REPORT; USE REPORT; + +PROCEDURE C34005G IS + + TYPE COMPONENT IS NEW CHARACTER; + + PACKAGE PKG IS + + FIRST : CONSTANT := 0; + LAST : CONSTANT := 100; + + SUBTYPE INDEX IS INTEGER RANGE FIRST .. LAST; + + TYPE PARENT IS ARRAY (INDEX RANGE <>) OF COMPONENT; + + FUNCTION CREATE ( F, L : INDEX; + C : COMPONENT; + DUMMY : PARENT -- TO RESOLVE OVERLOADING. + ) RETURN PARENT; + + END PKG; + + USE PKG; + + TYPE T IS NEW PARENT (IDENT_INT (5) .. IDENT_INT (7)); + + TYPE ARRT IS ARRAY (INTEGER RANGE <>) OF COMPONENT; + SUBTYPE ARR IS ARRT (2 .. 4); + + X : T := (OTHERS => 'B'); + W : PARENT (5 .. 7) := (OTHERS => 'B'); + C : COMPONENT := 'A'; + B : BOOLEAN := FALSE; + U : ARR := (OTHERS => C); + N : CONSTANT := 1; + + PROCEDURE A (X : ADDRESS) IS + BEGIN + B := IDENT_BOOL (TRUE); + END A; + + FUNCTION V RETURN T IS + BEGIN + RETURN (OTHERS => C); + END V; + + PACKAGE BODY PKG IS + + FUNCTION CREATE + ( F, L : INDEX; + C : COMPONENT; + DUMMY : PARENT + ) RETURN PARENT + IS + A : PARENT (F .. L); + B : COMPONENT := C; + BEGIN + FOR I IN F .. L LOOP + A (I) := B; + B := COMPONENT'SUCC (B); + END LOOP; + RETURN A; + END CREATE; + + END PKG; + + FUNCTION IDENT (X : T) RETURN T IS + BEGIN + IF EQUAL (X'LENGTH, X'LENGTH) THEN + RETURN X; -- ALWAYS EXECUTED. + END IF; + RETURN (OTHERS => '-'); + END IDENT; + +BEGIN + TEST ("C34005G", "CHECK THAT THE REQUIRED PREDEFINED OPERATIONS " & + "ARE DECLARED (IMPLICITLY) FOR DERIVED " & + "ONE-DIMENSIONAL ARRAY TYPES WHOSE COMPONENT " & + "TYPE IS A CHARACTER TYPE"); + + X := IDENT ("ABC"); + IF X /= "ABC" THEN + FAILED ("INCORRECT :="); + END IF; + + IF T'(X) /= "ABC" THEN + FAILED ("INCORRECT QUALIFICATION"); + END IF; + + IF T (X) /= "ABC" THEN + FAILED ("INCORRECT SELF CONVERSION"); + END IF; + + IF EQUAL (3, 3) THEN + W := "ABC"; + END IF; + IF T (W) /= "ABC" THEN + FAILED ("INCORRECT CONVERSION FROM PARENT"); + END IF; + + BEGIN + IF PARENT (X) /= "ABC" OR + PARENT (CREATE (2, 3, 'D', X)) /= "DE" THEN + FAILED ("INCORRECT CONVERSION TO PARENT"); + END IF; + EXCEPTION + WHEN CONSTRAINT_ERROR => + FAILED ("CALL TO CREATE RAISED CONSTRAINT_ERROR - 1"); + WHEN OTHERS => + FAILED ("CALL TO CREATE RAISED EXCEPTION - 1"); + END; + + IF EQUAL (3, 3) THEN + U := "ABC"; + END IF; + IF T (U) /= "ABC" THEN + FAILED ("INCORRECT CONVERSION FROM ARRAY"); + END IF; + + BEGIN + IF ARR (X) /= "ABC" OR + ARRT (CREATE (1, 2, 'C', X)) /= "CD" THEN + FAILED ("INCORRECT CONVERSION TO ARRAY"); + END IF; + EXCEPTION + WHEN CONSTRAINT_ERROR => + FAILED ("CALL TO CREATE RAISED CONSTRAINT_ERROR - 2"); + WHEN OTHERS => + FAILED ("CALL TO CREATE RAISED EXCEPTION - 2"); + END; + + IF IDENT ("ABC") /= ('A', 'B', 'C') OR + X = "AB" THEN + FAILED ("INCORRECT STRING LITERAL"); + END IF; + + IF IDENT (('A', 'B', 'C')) /= "ABC" OR + X = ('A', 'B') THEN + FAILED ("INCORRECT AGGREGATE"); + END IF; + + BEGIN + IF X (IDENT_INT (5)) /= 'A' OR + CREATE (2, 3, 'D', X) (3) /= 'E' THEN + FAILED ("INCORRECT INDEX (VALUE)"); + END IF; + EXCEPTION + WHEN CONSTRAINT_ERROR => + FAILED ("CALL TO CREATE RAISED CONSTRAINT_ERROR - 3"); + WHEN OTHERS => + FAILED ("CALL TO CREATE RAISED EXCEPTION - 3"); + END; + + X (IDENT_INT (7)) := 'D'; + IF X /= "ABD" THEN + FAILED ("INCORRECT INDEX (ASSIGNMENT)"); + END IF; + + BEGIN + X := IDENT ("ABC"); + IF X (IDENT_INT (6) .. IDENT_INT (7)) /= "BC" OR + CREATE (1, 4, 'D', X) (1 .. 3) /= "DEF" THEN + FAILED ("INCORRECT SLICE (VALUE)"); + END IF; + EXCEPTION + WHEN CONSTRAINT_ERROR => + FAILED ("CALL TO CREATE RAISED CONSTRAINT_ERROR - 4"); + WHEN OTHERS => + FAILED ("CALL TO CREATE RAISED EXCEPTION - 4"); + END; + + X (IDENT_INT (5) .. IDENT_INT (6)) := "DE"; + IF X /= "DEC" THEN + FAILED ("INCORRECT SLICE (ASSIGNMENT)"); + END IF; + + X := IDENT ("ABC"); + IF X = IDENT ("ABD") OR X = "AB" THEN + FAILED ("INCORRECT ="); + END IF; + + IF X /= IDENT ("ABC") OR NOT (X /= "BC") THEN + FAILED ("INCORRECT /="); + END IF; + + IF X < IDENT ("ABC") OR X < "AB" THEN + FAILED ("INCORRECT <"); + END IF; + + IF X > IDENT ("ABC") OR X > "AC" THEN + FAILED ("INCORRECT >"); + END IF; + + IF X <= IDENT ("ABB") OR X <= "ABBD" THEN + FAILED ("INCORRECT <="); + END IF; + + IF X >= IDENT ("ABD") OR X >= "ABCA" THEN + FAILED ("INCORRECT >="); + END IF; + + IF NOT (X IN T) OR "AB" IN T THEN + FAILED ("INCORRECT ""IN"""); + END IF; + + IF X NOT IN T OR NOT ("AB" NOT IN T) THEN + FAILED ("INCORRECT ""NOT IN"""); + END IF; + + BEGIN + IF X & "DEF" /= "ABCDEF" OR + CREATE (2, 3, 'B', X) & "DE" /= "BCDE" THEN + FAILED ("INCORRECT & (ARRAY, ARRAY)"); + END IF; + EXCEPTION + WHEN CONSTRAINT_ERROR => + FAILED ("CALL TO CREATE RAISED CONSTRAINT_ERROR - 5"); + WHEN OTHERS => + FAILED ("CALL TO CREATE RAISED EXCEPTION - 5"); + END; + + BEGIN + IF X & 'D' /= "ABCD" OR + CREATE (2, 3, 'B', X) & 'D' /= "BCD" THEN + FAILED ("INCORRECT & (ARRAY, COMPONENT)"); + END IF; + EXCEPTION + WHEN CONSTRAINT_ERROR => + FAILED ("CALL TO CREATE RAISED CONSTRAINT_ERROR - 6"); + WHEN OTHERS => + FAILED ("CALL TO CREATE RAISED EXCEPTION - 6"); + END; + + BEGIN + IF 'D' & X /= "DABC" OR + 'B' & CREATE (2, 3, 'C', X) /= "BCD" THEN + FAILED ("INCORRECT & (COMPONENT, ARRAY)"); + END IF; + EXCEPTION + WHEN CONSTRAINT_ERROR => + FAILED ("CALL TO CREATE RAISED CONSTRAINT_ERROR - 7"); + WHEN OTHERS => + FAILED ("CALL TO CREATE RAISED EXCEPTION - 7"); + END; + + IF EQUAL (3, 3) THEN + C := 'B'; + END IF; + + BEGIN + IF C & 'C' /= CREATE (2, 3, 'B', X) THEN + FAILED ("INCORRECT & (COMPONENT, COMPONENT)"); + END IF; + EXCEPTION + WHEN CONSTRAINT_ERROR => + FAILED ("CALL TO CREATE RAISED CONSTRAINT_ERROR - 8"); + WHEN OTHERS => + FAILED ("CALL TO CREATE RAISED EXCEPTION - 8"); + END; + + B := FALSE; + A (X'ADDRESS); + IF NOT B THEN + FAILED ("INCORRECT 'ADDRESS"); + END IF; + + IF T'FIRST /= 5 THEN + FAILED ("INCORRECT TYPE'FIRST"); + END IF; + + IF X'FIRST /= 5 THEN + FAILED ("INCORRECT OBJECT'FIRST"); + END IF; + + IF V'FIRST /= 5 THEN + FAILED ("INCORRECT VALUE'FIRST"); + END IF; + + IF T'FIRST (N) /= 5 THEN + FAILED ("INCORRECT TYPE'FIRST (N)"); + END IF; + + IF X'FIRST (N) /= 5 THEN + FAILED ("INCORRECT OBJECT'FIRST (N)"); + END IF; + + IF V'FIRST (N) /= 5 THEN + FAILED ("INCORRECT VALUE'FIRST (N)"); + END IF; + + IF T'LAST /= 7 THEN + FAILED ("INCORRECT TYPE'LAST"); + END IF; + + IF X'LAST /= 7 THEN + FAILED ("INCORRECT OBJECT'LAST"); + END IF; + + IF V'LAST /= 7 THEN + FAILED ("INCORRECT VALUE'LAST"); + END IF; + + IF T'LAST (N) /= 7 THEN + FAILED ("INCORRECT TYPE'LAST (N)"); + END IF; + + IF X'LAST (N) /= 7 THEN + FAILED ("INCORRECT OBJECT'LAST (N)"); + END IF; + + IF V'LAST (N) /= 7 THEN + FAILED ("INCORRECT VALUE'LAST (N)"); + END IF; + + IF T'LENGTH /= 3 THEN + FAILED ("INCORRECT TYPE'LENGTH"); + END IF; + + IF X'LENGTH /= 3 THEN + FAILED ("INCORRECT OBJECT'LENGTH"); + END IF; + + IF V'LENGTH /= 3 THEN + FAILED ("INCORRECT VALUE'LENGTH"); + END IF; + + IF T'LENGTH (N) /= 3 THEN + FAILED ("INCORRECT TYPE'LENGTH (N)"); + END IF; + + IF X'LENGTH (N) /= 3 THEN + FAILED ("INCORRECT OBJECT'LENGTH (N)"); + END IF; + + IF V'LENGTH (N) /= 3 THEN + FAILED ("INCORRECT VALUE'LENGTH (N)"); + END IF; + + DECLARE + Y : PARENT (T'RANGE); + BEGIN + IF Y'FIRST /= 5 OR Y'LAST /= 7 THEN + FAILED ("INCORRECT TYPE'RANGE"); + END IF; + END; + + DECLARE + Y : PARENT (X'RANGE); + BEGIN + IF Y'FIRST /= 5 OR Y'LAST /= 7 THEN + FAILED ("INCORRECT OBJECT'RANGE"); + END IF; + END; + + DECLARE + Y : PARENT (V'RANGE); + BEGIN + IF Y'FIRST /= 5 OR Y'LAST /= 7 THEN + FAILED ("INCORRECT VALUE'RANGE"); + END IF; + END; + + DECLARE + Y : PARENT (T'RANGE (N)); + BEGIN + IF Y'FIRST /= 5 OR Y'LAST /= 7 THEN + FAILED ("INCORRECT TYPE'RANGE (N)"); + END IF; + END; + + DECLARE + Y : PARENT (X'RANGE (N)); + BEGIN + IF Y'FIRST /= 5 OR Y'LAST /= 7 THEN + FAILED ("INCORRECT OBJECT'RANGE (N)"); + END IF; + END; + + DECLARE + Y : PARENT (V'RANGE (N)); + BEGIN + IF Y'FIRST /= 5 OR Y'LAST /= 7 THEN + FAILED ("INCORRECT VALUE'RANGE (N)"); + END IF; + END; + + RESULT; +END C34005G; diff --git a/gcc-4.9/gcc/testsuite/ada/acats/tests/c3/c34005i.ada b/gcc-4.9/gcc/testsuite/ada/acats/tests/c3/c34005i.ada new file mode 100644 index 000000000..580880e25 --- /dev/null +++ b/gcc-4.9/gcc/testsuite/ada/acats/tests/c3/c34005i.ada @@ -0,0 +1,195 @@ +-- C34005I.ADA + +-- Grant of Unlimited Rights +-- +-- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687, +-- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained +-- unlimited rights in the software and documentation contained herein. +-- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making +-- this public release, the Government intends to confer upon all +-- recipients unlimited rights equal to those held by the Government. +-- These rights include rights to use, duplicate, release or disclose the +-- released technical data and computer software in whole or in part, in +-- any manner and for any purpose whatsoever, and to have or permit others +-- to do so. +-- +-- DISCLAIMER +-- +-- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR +-- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED +-- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE +-- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE +-- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A +-- PARTICULAR PURPOSE OF SAID MATERIAL. +--* +-- OBJECTIVE: +-- FOR DERIVED ONE-DIMENSIONAL ARRAY TYPES WHOSE COMPONENT TYPE IS A +-- CHARACTER TYPE: +-- CHECK THAT ALL VALUES OF THE PARENT (BASE) TYPE ARE PRESENT FOR +-- THE DERIVED (BASE) TYPE WHEN THE DERIVED TYPE DEFINITION IS +-- CONSTRAINED. +-- CHECK THAT ANY CONSTRAINT IMPOSED ON THE PARENT SUBTYPE IS ALSO +-- IMPOSED ON THE DERIVED SUBTYPE. + +-- HISTORY: +-- JRK 9/15/86 CREATED ORIGINAL TEST. + +WITH REPORT; USE REPORT; + +PROCEDURE C34005I IS + + TYPE COMPONENT IS NEW CHARACTER; + + PACKAGE PKG IS + + FIRST : CONSTANT := 0; + LAST : CONSTANT := 100; + + SUBTYPE INDEX IS INTEGER RANGE FIRST .. LAST; + + TYPE PARENT IS ARRAY (INDEX RANGE <>) OF COMPONENT; + + FUNCTION CREATE ( F, L : INDEX; + C : COMPONENT; + DUMMY : PARENT -- TO RESOLVE OVERLOADING. + ) RETURN PARENT; + + END PKG; + + USE PKG; + + TYPE T IS NEW PARENT (IDENT_INT (5) .. IDENT_INT (7)); + + SUBTYPE SUBPARENT IS PARENT (5 .. 7); + + TYPE S IS NEW SUBPARENT; + + X : T := (OTHERS => 'B'); + Y : S := (OTHERS => 'B'); + + PACKAGE BODY PKG IS + + FUNCTION CREATE + ( F, L : INDEX; + C : COMPONENT; + DUMMY : PARENT + ) RETURN PARENT + IS + A : PARENT (F .. L); + B : COMPONENT := C; + BEGIN + FOR I IN F .. L LOOP + A (I) := B; + B := COMPONENT'SUCC (B); + END LOOP; + RETURN A; + END CREATE; + + END PKG; + +BEGIN + TEST ("C34005I", "CHECK THAT ALL VALUES OF THE PARENT (BASE) " & + "TYPE ARE PRESENT FOR THE DERIVED (BASE) TYPE " & + "WHEN THE DERIVED TYPE DEFINITION IS " & + "CONSTRAINED. ALSO CHECK THAT ANY CONSTRAINT " & + "IMPOSED ON THE PARENT SUBTYPE IS ALSO IMPOSED " & + "ON THE DERIVED SUBTYPE. CHECK FOR DERIVED " & + "ONE-DIMENSIONAL ARRAY TYPES WHOSE COMPONENT " & + "TYPE IS A CHARACTER TYPE"); + + -- CHECK THAT BASE TYPE VALUES NOT IN THE SUBTYPE ARE PRESENT. + + BEGIN + IF CREATE (2, 3, 'D', X) /= "DE" OR + CREATE (2, 3, 'D', Y) /= "DE" THEN + FAILED ("CAN'T CREATE BASE TYPE VALUES OUTSIDE THE " & + "SUBTYPE"); + END IF; + EXCEPTION + WHEN CONSTRAINT_ERROR => + FAILED ("CALL TO CREATE RAISED CONSTRAINT_ERROR"); + WHEN OTHERS => + FAILED ("CALL TO CREATE RAISED EXCEPTION"); + END; + + IF X & "CD" /= "BBBCD" OR + Y & "CD" /= "BBBCD" THEN + FAILED ("INCORRECT &"); + END IF; + + -- CHECK THE DERIVED SUBTYPE CONSTRAINT. + + IF T'FIRST /= 5 OR T'LAST /= 7 OR + S'FIRST /= 5 OR S'LAST /= 7 THEN + FAILED ("INCORRECT 'FIRST OR 'LAST"); + END IF; + + BEGIN + X := "ABC"; + Y := "ABC"; + IF PARENT (X) /= PARENT (Y) THEN -- USE X AND Y. + FAILED ("INCORRECT CONVERSION TO PARENT"); + END IF; + EXCEPTION + WHEN OTHERS => + FAILED ("EXCEPTION RAISED BY OK ASSIGNMENT"); + END; + + BEGIN + X := "AB"; + FAILED ("CONSTRAINT_ERROR NOT RAISED -- X := ""AB"""); + IF X = "AB" THEN -- USE X. + COMMENT ("X ALTERED -- X := ""AB"""); + END IF; + EXCEPTION + WHEN CONSTRAINT_ERROR => + NULL; + WHEN OTHERS => + FAILED ("WRONG EXCEPTION RAISED -- X := ""AB"""); + END; + + BEGIN + X := "ABCD"; + FAILED ("CONSTRAINT_ERROR NOT RAISED -- " & + "X := ""ABCD"""); + IF X = "ABCD" THEN -- USE X. + COMMENT ("X ALTERED -- X := ""ABCD"""); + END IF; + EXCEPTION + WHEN CONSTRAINT_ERROR => + NULL; + WHEN OTHERS => + FAILED ("WRONG EXCEPTION RAISED -- " & + "X := ""ABCD"""); + END; + + BEGIN + Y := "AB"; + FAILED ("CONSTRAINT_ERROR NOT RAISED -- Y := ""AB"""); + IF Y = "AB" THEN -- USE Y. + COMMENT ("Y ALTERED -- Y := ""AB"""); + END IF; + EXCEPTION + WHEN CONSTRAINT_ERROR => + NULL; + WHEN OTHERS => + FAILED ("WRONG EXCEPTION RAISED -- Y := ""AB"""); + END; + + BEGIN + Y := "ABCD"; + FAILED ("CONSTRAINT_ERROR NOT RAISED -- " & + "Y := ""ABCD"""); + IF Y = "ABCD" THEN -- USE Y. + COMMENT ("Y ALTERED -- Y := ""ABCD"""); + END IF; + EXCEPTION + WHEN CONSTRAINT_ERROR => + NULL; + WHEN OTHERS => + FAILED ("WRONG EXCEPTION RAISED -- " & + "Y := ""ABCD"""); + END; + + RESULT; +END C34005I; diff --git a/gcc-4.9/gcc/testsuite/ada/acats/tests/c3/c34005j.ada b/gcc-4.9/gcc/testsuite/ada/acats/tests/c3/c34005j.ada new file mode 100644 index 000000000..67910aab8 --- /dev/null +++ b/gcc-4.9/gcc/testsuite/ada/acats/tests/c3/c34005j.ada @@ -0,0 +1,482 @@ +-- C34005J.ADA + +-- Grant of Unlimited Rights +-- +-- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687, +-- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained +-- unlimited rights in the software and documentation contained herein. +-- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making +-- this public release, the Government intends to confer upon all +-- recipients unlimited rights equal to those held by the Government. +-- These rights include rights to use, duplicate, release or disclose the +-- released technical data and computer software in whole or in part, in +-- any manner and for any purpose whatsoever, and to have or permit others +-- to do so. +-- +-- DISCLAIMER +-- +-- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR +-- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED +-- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF 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 REQUIRED PREDEFINED OPERATIONS ARE DECLARED +-- (IMPLICITLY) FOR DERIVED ONE-DIMENSIONAL ARRAY TYPES +-- WHOSE COMPONENT TYPE IS A BOOLEAN TYPE. + +-- HISTORY: +-- JRK 9/16/86 CREATED ORIGINAL TEST. +-- RJW 8/21/89 MODIFIED CHECKS FOR TYPE AND OBJECT SIZES. +-- PWN 11/30/94 REMOVED 'BASE USE ILLEGAL IN ADA 9X. + +WITH SYSTEM; USE SYSTEM; +WITH REPORT; USE REPORT; + +PROCEDURE C34005J IS + + SUBTYPE COMPONENT IS BOOLEAN; + + PACKAGE PKG IS + + FIRST : CONSTANT := 0; + LAST : CONSTANT := 100; + + SUBTYPE INDEX IS INTEGER RANGE FIRST .. LAST; + + TYPE PARENT IS ARRAY (INDEX RANGE <>) OF COMPONENT; + + FUNCTION CREATE ( F, L : INDEX; + C : COMPONENT; + DUMMY : PARENT -- TO RESOLVE OVERLOADING. + ) RETURN PARENT; + + END PKG; + + USE PKG; + + TYPE T IS NEW PARENT (IDENT_INT (5) .. IDENT_INT (7)); + + TYPE ARRT IS ARRAY (INTEGER RANGE <>) OF COMPONENT; + SUBTYPE ARR IS ARRT (2 .. 4); + + X : T := (OTHERS => TRUE); + W : PARENT (5 .. 7) := (OTHERS => TRUE); + C : COMPONENT := FALSE; + B : BOOLEAN := FALSE; + U : ARR := (OTHERS => C); + N : CONSTANT := 1; + + PROCEDURE A (X : ADDRESS) IS + BEGIN + B := IDENT_BOOL (TRUE); + END A; + + FUNCTION V RETURN T IS + BEGIN + RETURN (OTHERS => C); + END V; + + PACKAGE BODY PKG IS + + FUNCTION CREATE + ( F, L : INDEX; + C : COMPONENT; + DUMMY : PARENT + ) RETURN PARENT + IS + A : PARENT (F .. L); + B : COMPONENT := C; + BEGIN + FOR I IN F .. L LOOP + A (I) := B; + B := NOT B; + END LOOP; + RETURN A; + END CREATE; + + END PKG; + + FUNCTION IDENT (X : T) RETURN T IS + BEGIN + IF EQUAL (X'LENGTH, X'LENGTH) THEN + RETURN X; -- ALWAYS EXECUTED. + END IF; + RETURN (OTHERS => FALSE); + END IDENT; + +BEGIN + TEST ("C34005J", "CHECK THAT THE REQUIRED PREDEFINED OPERATIONS " & + "ARE DECLARED (IMPLICITLY) FOR DERIVED " & + "ONE-DIMENSIONAL ARRAY TYPES WHOSE COMPONENT " & + "TYPE IS A BOOLEAN TYPE"); + + X := IDENT ((TRUE, FALSE, TRUE)); + IF X /= (TRUE, FALSE, TRUE) THEN + FAILED ("INCORRECT :="); + END IF; + + IF T'(X) /= (TRUE, FALSE, TRUE) THEN + FAILED ("INCORRECT QUALIFICATION"); + END IF; + + IF T (X) /= (TRUE, FALSE, TRUE) THEN + FAILED ("INCORRECT SELF CONVERSION"); + END IF; + + IF EQUAL (3, 3) THEN + W := (TRUE, FALSE, TRUE); + END IF; + IF T (W) /= (TRUE, FALSE, TRUE) THEN + FAILED ("INCORRECT CONVERSION FROM PARENT"); + END IF; + + BEGIN + IF PARENT (X) /= (TRUE, FALSE, TRUE) OR + PARENT (CREATE (2, 3, FALSE, X)) /= (FALSE, TRUE) THEN + FAILED ("INCORRECT CONVERSION TO PARENT"); + END IF; + EXCEPTION + WHEN CONSTRAINT_ERROR => + FAILED ("CALL TO CREATE RAISED CONSTRAINT_ERROR - 1"); + WHEN OTHERS => + FAILED ("CALL TO CREATE RAISED EXCEPTION - 1"); + END; + + IF EQUAL (3, 3) THEN + U := (TRUE, FALSE, TRUE); + END IF; + IF T (U) /= (TRUE, FALSE, TRUE) THEN + FAILED ("INCORRECT CONVERSION FROM ARRAY"); + END IF; + + BEGIN + IF ARR (X) /= (TRUE, FALSE, TRUE) OR + ARRT (CREATE (1, 2, TRUE, X)) /= (TRUE, FALSE) THEN + FAILED ("INCORRECT CONVERSION TO ARRAY"); + END IF; + EXCEPTION + WHEN CONSTRAINT_ERROR => + FAILED ("CALL TO CREATE RAISED CONSTRAINT_ERROR - 2"); + WHEN OTHERS => + FAILED ("CALL TO CREATE RAISED EXCEPTION - 2"); + END; + + IF IDENT ((TRUE, FALSE, TRUE)) /= (TRUE, FALSE, TRUE) OR + X = (TRUE, FALSE) THEN + FAILED ("INCORRECT AGGREGATE"); + END IF; + + BEGIN + IF X (IDENT_INT (5)) /= TRUE OR + CREATE (2, 3, FALSE, X) (3) /= TRUE THEN + FAILED ("INCORRECT INDEX (VALUE)"); + END IF; + EXCEPTION + WHEN CONSTRAINT_ERROR => + FAILED ("CALL TO CREATE RAISED CONSTRAINT_ERROR - 3"); + WHEN OTHERS => + FAILED ("CALL TO CREATE RAISED EXCEPTION - 3"); + END; + + X (IDENT_INT (7)) := FALSE; + IF X /= (TRUE, FALSE, FALSE) THEN + FAILED ("INCORRECT INDEX (ASSIGNMENT)"); + END IF; + + BEGIN + X := IDENT ((TRUE, FALSE, TRUE)); + IF X (IDENT_INT (6) .. IDENT_INT (7)) /= (FALSE, TRUE) OR + CREATE (1, 4, FALSE, X) (1 .. 3) /= + (FALSE, TRUE, FALSE) THEN + FAILED ("INCORRECT SLICE (VALUE)"); + END IF; + EXCEPTION + WHEN CONSTRAINT_ERROR => + FAILED ("CALL TO CREATE RAISED CONSTRAINT_ERROR - 4"); + WHEN OTHERS => + FAILED ("CALL TO CREATE RAISED EXCEPTION - 4"); + END; + + X (IDENT_INT (5) .. IDENT_INT (6)) := (FALSE, TRUE); + IF X /= (FALSE, TRUE, TRUE) THEN + FAILED ("INCORRECT SLICE (ASSIGNMENT)"); + END IF; + + BEGIN + X := IDENT ((TRUE, FALSE, TRUE)); + IF NOT X /= (FALSE, TRUE, FALSE) OR + NOT CREATE (2, 3, FALSE, X) /= (TRUE, FALSE) THEN + FAILED ("INCORRECT ""NOT"""); + END IF; + EXCEPTION + WHEN CONSTRAINT_ERROR => + FAILED ("CALL TO CREATE RAISED CONSTRAINT_ERROR - 5"); + WHEN OTHERS => + FAILED ("CALL TO CREATE RAISED EXCEPTION - 5"); + END; + + BEGIN + IF (X AND IDENT ((TRUE, TRUE, FALSE))) /= + (TRUE, FALSE, FALSE) OR + (CREATE (1, 4, FALSE, X) AND + (FALSE, FALSE, TRUE, TRUE)) /= + (FALSE, FALSE, FALSE, TRUE) THEN + FAILED ("INCORRECT ""AND"""); + END IF; + EXCEPTION + WHEN CONSTRAINT_ERROR => + FAILED ("CALL TO CREATE RAISED CONSTRAINT_ERROR - 6"); + WHEN OTHERS => + FAILED ("CALL TO CREATE RAISED EXCEPTION - 6"); + END; + + BEGIN + IF (X OR IDENT ((TRUE, FALSE, FALSE))) /= + (TRUE, FALSE, TRUE) OR + (CREATE (1, 4, FALSE, X) OR (FALSE, FALSE, TRUE, TRUE)) /= + (FALSE, TRUE, TRUE, TRUE) THEN + FAILED ("INCORRECT ""OR"""); + END IF; + EXCEPTION + WHEN CONSTRAINT_ERROR => + FAILED ("CALL TO CREATE RAISED CONSTRAINT_ERROR - 7"); + WHEN OTHERS => + FAILED ("CALL TO CREATE RAISED EXCEPTION - 7"); + END; + + BEGIN + IF (X XOR IDENT ((TRUE, TRUE, FALSE))) /= + (FALSE, TRUE, TRUE) OR + (CREATE (1, 4, FALSE, X) XOR + (FALSE, FALSE, TRUE, TRUE)) /= + (FALSE, TRUE, TRUE, FALSE) THEN + FAILED ("INCORRECT ""XOR"""); + END IF; + EXCEPTION + WHEN CONSTRAINT_ERROR => + FAILED ("CALL TO CREATE RAISED CONSTRAINT_ERROR - 8"); + WHEN OTHERS => + FAILED ("CALL TO CREATE RAISED EXCEPTION - 8"); + END; + + IF X = IDENT ((TRUE, FALSE, FALSE)) OR X = (TRUE, FALSE) THEN + FAILED ("INCORRECT ="); + END IF; + + IF X /= IDENT ((TRUE, FALSE, TRUE)) OR + NOT (X /= (FALSE, TRUE)) THEN + FAILED ("INCORRECT /="); + END IF; + + IF X < IDENT ((TRUE, FALSE, TRUE)) OR X < (TRUE, FALSE) THEN + FAILED ("INCORRECT <"); + END IF; + + IF X > IDENT ((TRUE, FALSE, TRUE)) OR X > (TRUE, TRUE) THEN + FAILED ("INCORRECT >"); + END IF; + + IF X <= IDENT ((TRUE, FALSE, FALSE)) OR + X <= (TRUE, FALSE, FALSE, TRUE) THEN + FAILED ("INCORRECT <="); + END IF; + + IF X >= IDENT ((TRUE, TRUE, FALSE)) OR + X >= (TRUE, FALSE, TRUE, FALSE) THEN + FAILED ("INCORRECT >="); + END IF; + + IF NOT (X IN T) OR (TRUE, FALSE) IN T THEN + FAILED ("INCORRECT ""IN"""); + END IF; + + IF X NOT IN T OR NOT ((TRUE, FALSE) NOT IN T) THEN + FAILED ("INCORRECT ""NOT IN"""); + END IF; + + BEGIN + IF X & (FALSE, TRUE, FALSE) /= + (TRUE, FALSE, TRUE, FALSE, TRUE, FALSE) OR + CREATE (2, 3, FALSE, X) & (FALSE, TRUE) /= + (FALSE, TRUE, FALSE, TRUE) THEN + FAILED ("INCORRECT & (ARRAY, ARRAY)"); + END IF; + EXCEPTION + WHEN CONSTRAINT_ERROR => + FAILED ("CALL TO CREATE RAISED CONSTRAINT_ERROR - 9"); + WHEN OTHERS => + FAILED ("CALL TO CREATE RAISED EXCEPTION - 9"); + END; + + BEGIN + IF X & FALSE /= (TRUE, FALSE, TRUE, FALSE) OR + CREATE (2, 3, FALSE, X) & FALSE /= + (FALSE, TRUE, FALSE) THEN + FAILED ("INCORRECT & (ARRAY, COMPONENT)"); + END IF; + EXCEPTION + WHEN CONSTRAINT_ERROR => + FAILED ("CALL TO CREATE RAISED CONSTRAINT_ERROR - 10"); + WHEN OTHERS => + FAILED ("CALL TO CREATE RAISED EXCEPTION - 10"); + END; + + BEGIN + IF FALSE & X /= (FALSE, TRUE, FALSE, TRUE) OR + FALSE & CREATE (2, 3, TRUE, X) /= + (FALSE, TRUE, FALSE) THEN + FAILED ("INCORRECT & (COMPONENT, ARRAY)"); + END IF; + EXCEPTION + WHEN CONSTRAINT_ERROR => + FAILED ("CALL TO CREATE RAISED CONSTRAINT_ERROR - 11"); + WHEN OTHERS => + FAILED ("CALL TO CREATE RAISED EXCEPTION - 11"); + END; + + IF EQUAL (3, 3) THEN + C := FALSE; + END IF; + + BEGIN + IF C & TRUE /= CREATE (2, 3, FALSE, X) THEN + FAILED ("INCORRECT & (COMPONENT, COMPONENT)"); + END IF; + EXCEPTION + WHEN CONSTRAINT_ERROR => + FAILED ("CALL TO CREATE RAISED CONSTRAINT_ERROR - 12"); + WHEN OTHERS => + FAILED ("CALL TO CREATE RAISED EXCEPTION - 12"); + END; + + B := FALSE; + A (X'ADDRESS); + IF NOT B THEN + FAILED ("INCORRECT 'ADDRESS"); + END IF; + + IF T'FIRST /= 5 THEN + FAILED ("INCORRECT TYPE'FIRST"); + END IF; + + IF X'FIRST /= 5 THEN + FAILED ("INCORRECT OBJECT'FIRST"); + END IF; + + IF V'FIRST /= 5 THEN + FAILED ("INCORRECT VALUE'FIRST"); + END IF; + + IF T'FIRST (N) /= 5 THEN + FAILED ("INCORRECT TYPE'FIRST (N)"); + END IF; + + IF X'FIRST (N) /= 5 THEN + FAILED ("INCORRECT OBJECT'FIRST (N)"); + END IF; + + IF V'FIRST (N) /= 5 THEN + FAILED ("INCORRECT VALUE'FIRST (N)"); + END IF; + + IF T'LAST /= 7 THEN + FAILED ("INCORRECT TYPE'LAST"); + END IF; + + IF X'LAST /= 7 THEN + FAILED ("INCORRECT OBJECT'LAST"); + END IF; + + IF V'LAST /= 7 THEN + FAILED ("INCORRECT VALUE'LAST"); + END IF; + + IF T'LAST (N) /= 7 THEN + FAILED ("INCORRECT TYPE'LAST (N)"); + END IF; + + IF X'LAST (N) /= 7 THEN + FAILED ("INCORRECT OBJECT'LAST (N)"); + END IF; + + IF V'LAST (N) /= 7 THEN + FAILED ("INCORRECT VALUE'LAST (N)"); + END IF; + + IF T'LENGTH /= 3 THEN + FAILED ("INCORRECT TYPE'LENGTH"); + END IF; + + IF X'LENGTH /= 3 THEN + FAILED ("INCORRECT OBJECT'LENGTH"); + END IF; + + IF V'LENGTH /= 3 THEN + FAILED ("INCORRECT VALUE'LENGTH"); + END IF; + + IF T'LENGTH (N) /= 3 THEN + FAILED ("INCORRECT TYPE'LENGTH (N)"); + END IF; + + IF X'LENGTH (N) /= 3 THEN + FAILED ("INCORRECT OBJECT'LENGTH (N)"); + END IF; + + IF V'LENGTH (N) /= 3 THEN + FAILED ("INCORRECT VALUE'LENGTH (N)"); + END IF; + + DECLARE + Y : PARENT (T'RANGE); + BEGIN + IF Y'FIRST /= 5 OR Y'LAST /= 7 THEN + FAILED ("INCORRECT TYPE'RANGE"); + END IF; + END; + + DECLARE + Y : PARENT (X'RANGE); + BEGIN + IF Y'FIRST /= 5 OR Y'LAST /= 7 THEN + FAILED ("INCORRECT OBJECT'RANGE"); + END IF; + END; + + DECLARE + Y : PARENT (V'RANGE); + BEGIN + IF Y'FIRST /= 5 OR Y'LAST /= 7 THEN + FAILED ("INCORRECT VALUE'RANGE"); + END IF; + END; + + DECLARE + Y : PARENT (T'RANGE (N)); + BEGIN + IF Y'FIRST /= 5 OR Y'LAST /= 7 THEN + FAILED ("INCORRECT TYPE'RANGE (N)"); + END IF; + END; + + DECLARE + Y : PARENT (X'RANGE (N)); + BEGIN + IF Y'FIRST /= 5 OR Y'LAST /= 7 THEN + FAILED ("INCORRECT OBJECT'RANGE (N)"); + END IF; + END; + + DECLARE + Y : PARENT (V'RANGE (N)); + BEGIN + IF Y'FIRST /= 5 OR Y'LAST /= 7 THEN + FAILED ("INCORRECT VALUE'RANGE (N)"); + END IF; + END; + + RESULT; +END C34005J; diff --git a/gcc-4.9/gcc/testsuite/ada/acats/tests/c3/c34005l.ada b/gcc-4.9/gcc/testsuite/ada/acats/tests/c3/c34005l.ada new file mode 100644 index 000000000..2aba733f3 --- /dev/null +++ b/gcc-4.9/gcc/testsuite/ada/acats/tests/c3/c34005l.ada @@ -0,0 +1,195 @@ +-- C34005L.ADA + +-- Grant of Unlimited Rights +-- +-- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687, +-- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained +-- unlimited rights in the software and documentation contained herein. +-- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making +-- this public release, the Government intends to confer upon all +-- recipients unlimited rights equal to those held by the Government. +-- These rights include rights to use, duplicate, release or disclose the +-- released technical data and computer software in whole or in part, in +-- any manner and for any purpose whatsoever, and to have or permit others +-- to do so. +-- +-- DISCLAIMER +-- +-- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR +-- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED +-- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE +-- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE +-- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A +-- PARTICULAR PURPOSE OF SAID MATERIAL. +--* +-- OBJECTIVE: +-- FOR DERIVED ONE-DIMENSIONAL ARRAY TYPES WHOSE COMPONENT TYPE IS A +-- BOOLEAN TYPE: +-- CHECK THAT ALL VALUES OF THE PARENT (BASE) TYPE ARE PRESENT FOR +-- THE DERIVED (BASE) TYPE WHEN THE DERIVED TYPE DEFINITION IS +-- CONSTRAINED. +-- CHECK THAT ANY CONSTRAINT IMPOSED ON THE PARENT SUBTYPE IS ALSO +-- IMPOSED ON THE DERIVED SUBTYPE. + +-- HISTORY: +-- JRK 9/16/86 CREATED ORIGINAL TEST. + +WITH REPORT; USE REPORT; + +PROCEDURE C34005L IS + + SUBTYPE COMPONENT IS BOOLEAN; + + PACKAGE PKG IS + + FIRST : CONSTANT := 0; + LAST : CONSTANT := 100; + + SUBTYPE INDEX IS INTEGER RANGE FIRST .. LAST; + + TYPE PARENT IS ARRAY (INDEX RANGE <>) OF COMPONENT; + + FUNCTION CREATE ( F, L : INDEX; + C : COMPONENT; + DUMMY : PARENT -- TO RESOLVE OVERLOADING. + ) RETURN PARENT; + + END PKG; + + USE PKG; + + TYPE T IS NEW PARENT (IDENT_INT (5) .. IDENT_INT (7)); + + SUBTYPE SUBPARENT IS PARENT (5 .. 7); + + TYPE S IS NEW SUBPARENT; + + X : T := (OTHERS => TRUE); + Y : S := (OTHERS => TRUE); + + PACKAGE BODY PKG IS + + FUNCTION CREATE + ( F, L : INDEX; + C : COMPONENT; + DUMMY : PARENT + ) RETURN PARENT + IS + A : PARENT (F .. L); + B : COMPONENT := C; + BEGIN + FOR I IN F .. L LOOP + A (I) := B; + B := NOT B; + END LOOP; + RETURN A; + END CREATE; + + END PKG; + +BEGIN + TEST ("C34005L", "CHECK THAT ALL VALUES OF THE PARENT (BASE) " & + "TYPE ARE PRESENT FOR THE DERIVED (BASE) TYPE " & + "WHEN THE DERIVED TYPE DEFINITION IS " & + "CONSTRAINED. ALSO CHECK THAT ANY CONSTRAINT " & + "IMPOSED ON THE PARENT SUBTYPE IS ALSO IMPOSED " & + "ON THE DERIVED SUBTYPE. CHECK FOR DERIVED " & + "ONE-DIMENSIONAL ARRAY TYPES WHOSE COMPONENT " & + "TYPE IS A BOOLEAN TYPE"); + + -- CHECK THAT BASE TYPE VALUES NOT IN THE SUBTYPE ARE PRESENT. + + BEGIN + IF CREATE (2, 3, FALSE, X) /= (FALSE, TRUE) OR + CREATE (2, 3, FALSE, Y) /= (FALSE, TRUE) THEN + FAILED ("CAN'T CREATE BASE TYPE VALUES OUTSIDE THE " & + "SUBTYPE"); + END IF; + EXCEPTION + WHEN CONSTRAINT_ERROR => + FAILED ("CALL TO CREATE RAISED CONSTRAINT_ERROR"); + WHEN OTHERS => + FAILED ("CALL TO CREATE RAISED EXCEPTION"); + END; + + IF X & (FALSE, TRUE) /= (TRUE, TRUE, TRUE, FALSE, TRUE) OR + Y & (FALSE, TRUE) /= (TRUE, TRUE, TRUE, FALSE, TRUE) THEN + FAILED ("INCORRECT &"); + END IF; + + -- CHECK THE DERIVED SUBTYPE CONSTRAINT. + + IF T'FIRST /= 5 OR T'LAST /= 7 OR + S'FIRST /= 5 OR S'LAST /= 7 THEN + FAILED ("INCORRECT 'FIRST OR 'LAST"); + END IF; + + BEGIN + X := (TRUE, FALSE, TRUE); + Y := (TRUE, FALSE, TRUE); + IF PARENT (X) /= PARENT (Y) THEN -- USE X AND Y. + FAILED ("INCORRECT CONVERSION TO PARENT"); + END IF; + EXCEPTION + WHEN OTHERS => + FAILED ("EXCEPTION RAISED BY OK ASSIGNMENT"); + END; + + BEGIN + X := (TRUE, FALSE); + FAILED ("CONSTRAINT_ERROR NOT RAISED -- X := (TRUE, FALSE)"); + IF X = (TRUE, FALSE) THEN -- USE X. + COMMENT ("X ALTERED -- X := (TRUE, FALSE)"); + END IF; + EXCEPTION + WHEN CONSTRAINT_ERROR => + NULL; + WHEN OTHERS => + FAILED ("WRONG EXCEPTION RAISED -- X := (TRUE, FALSE)"); + END; + + BEGIN + X := (TRUE, FALSE, TRUE, FALSE); + FAILED ("CONSTRAINT_ERROR NOT RAISED -- " & + "X := (TRUE, FALSE, TRUE, FALSE)"); + IF X = (TRUE, FALSE, TRUE, FALSE) THEN -- USE X. + COMMENT ("X ALTERED -- X := (TRUE, FALSE, TRUE, FALSE)"); + END IF; + EXCEPTION + WHEN CONSTRAINT_ERROR => + NULL; + WHEN OTHERS => + FAILED ("WRONG EXCEPTION RAISED -- " & + "X := (TRUE, FALSE, TRUE, FALSE)"); + END; + + BEGIN + Y := (TRUE, FALSE); + FAILED ("CONSTRAINT_ERROR NOT RAISED -- Y := (TRUE, FALSE)"); + IF Y = (TRUE, FALSE) THEN -- USE Y. + COMMENT ("Y ALTERED -- Y := (TRUE, FALSE)"); + END IF; + EXCEPTION + WHEN CONSTRAINT_ERROR => + NULL; + WHEN OTHERS => + FAILED ("WRONG EXCEPTION RAISED -- Y := (TRUE, FALSE)"); + END; + + BEGIN + Y := (TRUE, FALSE, TRUE, FALSE); + FAILED ("CONSTRAINT_ERROR NOT RAISED -- " & + "Y := (TRUE, FALSE, TRUE, FALSE)"); + IF Y = (TRUE, FALSE, TRUE, FALSE) THEN -- USE Y. + COMMENT ("Y ALTERED -- Y := (TRUE, FALSE, TRUE, FALSE)"); + END IF; + EXCEPTION + WHEN CONSTRAINT_ERROR => + NULL; + WHEN OTHERS => + FAILED ("WRONG EXCEPTION RAISED -- " & + "Y := (TRUE, FALSE, TRUE, FALSE)"); + END; + + RESULT; +END C34005L; diff --git a/gcc-4.9/gcc/testsuite/ada/acats/tests/c3/c34005m.ada b/gcc-4.9/gcc/testsuite/ada/acats/tests/c3/c34005m.ada new file mode 100644 index 000000000..51d319226 --- /dev/null +++ b/gcc-4.9/gcc/testsuite/ada/acats/tests/c3/c34005m.ada @@ -0,0 +1,353 @@ +-- C34005M.ADA + +-- Grant of Unlimited Rights +-- +-- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687, +-- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained +-- unlimited rights in the software and documentation contained herein. +-- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making +-- this public release, the Government intends to confer upon all +-- recipients unlimited rights equal to those held by the Government. +-- These rights include rights to use, duplicate, release or disclose the +-- released technical data and computer software in whole or in part, in +-- any manner and for any purpose whatsoever, and to have or permit others +-- to do so. +-- +-- DISCLAIMER +-- +-- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR +-- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED +-- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF 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 REQUIRED PREDEFINED OPERATIONS ARE DECLARED +-- (IMPLICITLY) FOR DERIVED MULTI-DIMENSIONAL ARRAY TYPES WHOSE +-- COMPONENT TYPE IS A NON-LIMITED TYPE. + +-- HISTORY: +-- JRK 9/17/86 CREATED ORIGINAL TEST. +-- PWN 11/30/94 REMOVED 'BASE USE ILLEGAL IN ADA 9X. + +WITH SYSTEM; USE SYSTEM; +WITH REPORT; USE REPORT; + +PROCEDURE C34005M IS + + SUBTYPE COMPONENT IS INTEGER; + + PACKAGE PKG IS + + FIRST : CONSTANT := 0; + LAST : CONSTANT := 10; + + SUBTYPE INDEX IS INTEGER RANGE FIRST .. LAST; + + TYPE PARENT IS ARRAY (INDEX RANGE <>, INDEX RANGE <>) OF + COMPONENT; + + FUNCTION CREATE ( F1, L1 : INDEX; + F2, L2 : INDEX; + C : COMPONENT; + DUMMY : PARENT -- TO RESOLVE OVERLOADING. + ) RETURN PARENT; + + END PKG; + + USE PKG; + + TYPE T IS NEW PARENT (IDENT_INT (4) .. IDENT_INT (5), + IDENT_INT (6) .. IDENT_INT (8)); + + TYPE ARRT IS ARRAY (INTEGER RANGE <>, INTEGER RANGE <>) OF + COMPONENT; + + SUBTYPE ARR IS ARRT (8 .. 9, 2 .. 4); + + X : T := (OTHERS => (OTHERS => 2)); + W : PARENT (4 .. 5, 6 .. 8) := (OTHERS => (OTHERS => 2)); + C : COMPONENT := 1; + B : BOOLEAN := FALSE; + U : ARR := (OTHERS => (OTHERS => C)); + N : CONSTANT := 2; + + PROCEDURE A (X : ADDRESS) IS + BEGIN + B := IDENT_BOOL (TRUE); + END A; + + FUNCTION V RETURN T IS + BEGIN + RETURN (OTHERS => (OTHERS => C)); + END V; + + PACKAGE BODY PKG IS + + FUNCTION CREATE + ( F1, L1 : INDEX; + F2, L2 : INDEX; + C : COMPONENT; + DUMMY : PARENT + ) RETURN PARENT + IS + A : PARENT (F1 .. L1, F2 .. L2); + B : COMPONENT := C; + BEGIN + FOR I IN F1 .. L1 LOOP + FOR J IN F2 .. L2 LOOP + A (I, J) := B; + B := B + 1; + END LOOP; + END LOOP; + RETURN A; + END CREATE; + + END PKG; + + FUNCTION IDENT (X : T) RETURN T IS + BEGIN + IF EQUAL (X'LENGTH, X'LENGTH) THEN + RETURN X; -- ALWAYS EXECUTED. + END IF; + RETURN (OTHERS => (OTHERS => -1)); + END IDENT; + +BEGIN + TEST ("C34005M", "CHECK THAT THE REQUIRED PREDEFINED OPERATIONS " & + "ARE DECLARED (IMPLICITLY) FOR DERIVED " & + "MULTI-DIMENSIONAL ARRAY TYPES WHOSE COMPONENT " & + "TYPE IS A NON-LIMITED TYPE"); + + X := IDENT (((1, 2, 3), (4, 5, 6))); + IF X /= ((1, 2, 3), (4, 5, 6)) THEN + FAILED ("INCORRECT :="); + END IF; + + IF T'(X) /= ((1, 2, 3), (4, 5, 6)) THEN + FAILED ("INCORRECT QUALIFICATION"); + END IF; + + IF T (X) /= ((1, 2, 3), (4, 5, 6)) THEN + FAILED ("INCORRECT SELF CONVERSION"); + END IF; + + IF EQUAL (3, 3) THEN + W := ((1, 2, 3), (4, 5, 6)); + END IF; + IF T (W) /= ((1, 2, 3), (4, 5, 6)) THEN + FAILED ("INCORRECT CONVERSION FROM PARENT"); + END IF; + + BEGIN + IF PARENT (X) /= ((1, 2, 3), (4, 5, 6)) OR + PARENT (CREATE (6, 9, 2, 3, 4, X)) /= + ((4, 5), (6, 7), (8, 9), (10, 11)) THEN + FAILED ("INCORRECT CONVERSION TO PARENT"); + END IF; + EXCEPTION + WHEN CONSTRAINT_ERROR => + FAILED ("CALL TO CREATE RAISED CONSTRAINT_ERROR - 1"); + WHEN OTHERS => + FAILED ("CALL TO CREATE RAISED EXCEPTION - 1"); + END; + + IF EQUAL (3, 3) THEN + U := ((1, 2, 3), (4, 5, 6)); + END IF; + IF T (U) /= ((1, 2, 3), (4, 5, 6)) THEN + FAILED ("INCORRECT CONVERSION FROM ARRAY"); + END IF; + + BEGIN + IF ARR (X) /= ((1, 2, 3), (4, 5, 6)) OR + ARRT (CREATE (7, 9, 2, 5, 3, X)) /= + ((3, 4, 5, 6), (7, 8, 9, 10), (11, 12, 13, 14)) THEN + FAILED ("INCORRECT CONVERSION TO ARRAY"); + END IF; + EXCEPTION + WHEN CONSTRAINT_ERROR => + FAILED ("CALL TO CREATE RAISED CONSTRAINT_ERROR - 2"); + WHEN OTHERS => + FAILED ("CALL TO CREATE RAISED EXCEPTION - 2"); + END; + + IF IDENT (((1, 2, 3), (4, 5, 6))) /= ((1, 2, 3), (4, 5, 6)) OR + X = ((1, 2), (3, 4), (5, 6)) THEN + FAILED ("INCORRECT AGGREGATE"); + END IF; + + BEGIN + IF X (IDENT_INT (4), IDENT_INT (6)) /= 1 OR + CREATE (6, 9, 2, 3, 4, X) (9, 3) /= 11 THEN + FAILED ("INCORRECT INDEX (VALUE)"); + END IF; + EXCEPTION + WHEN CONSTRAINT_ERROR => + FAILED ("CALL TO CREATE RAISED CONSTRAINT_ERROR - 3"); + WHEN OTHERS => + FAILED ("CALL TO CREATE RAISED EXCEPTION - 3"); + END; + + X (IDENT_INT (5), IDENT_INT (8)) := 7; + IF X /= ((1, 2, 3), (4, 5, 7)) THEN + FAILED ("INCORRECT INDEX (ASSIGNMENT)"); + END IF; + + X := IDENT (((1, 2, 3), (4, 5, 6))); + IF X = IDENT (((1, 2, 3), (4, 5, 7))) OR + X = ((1, 2), (4, 5)) THEN + FAILED ("INCORRECT ="); + END IF; + + IF X /= IDENT (((1, 2, 3), (4, 5, 6))) OR + NOT (X /= ((1, 2, 3), (4, 5, 6), (7, 8, 9))) THEN + FAILED ("INCORRECT /="); + END IF; + + IF NOT (X IN T) OR ((1, 2), (3, 4)) IN T THEN + FAILED ("INCORRECT ""IN"""); + END IF; + + IF X NOT IN T OR + NOT (((1, 2, 3), (4, 5, 6), (7, 8, 9)) NOT IN T) THEN + FAILED ("INCORRECT ""NOT IN"""); + END IF; + + B := FALSE; + A (X'ADDRESS); + IF NOT B THEN + FAILED ("INCORRECT 'ADDRESS"); + END IF; + + IF T'FIRST /= 4 THEN + FAILED ("INCORRECT TYPE'FIRST"); + END IF; + + IF X'FIRST /= 4 THEN + FAILED ("INCORRECT OBJECT'FIRST"); + END IF; + + IF V'FIRST /= 4 THEN + FAILED ("INCORRECT VALUE'FIRST"); + END IF; + + IF T'FIRST (N) /= 6 THEN + FAILED ("INCORRECT TYPE'FIRST (N)"); + END IF; + + IF X'FIRST (N) /= 6 THEN + FAILED ("INCORRECT OBJECT'FIRST (N)"); + END IF; + + IF V'FIRST (N) /= 6 THEN + FAILED ("INCORRECT VALUE'FIRST (N)"); + END IF; + + IF T'LAST /= 5 THEN + FAILED ("INCORRECT TYPE'LAST"); + END IF; + + IF X'LAST /= 5 THEN + FAILED ("INCORRECT OBJECT'LAST"); + END IF; + + IF V'LAST /= 5 THEN + FAILED ("INCORRECT VALUE'LAST"); + END IF; + + IF T'LAST (N) /= 8 THEN + FAILED ("INCORRECT TYPE'LAST (N)"); + END IF; + + IF X'LAST (N) /= 8 THEN + FAILED ("INCORRECT OBJECT'LAST (N)"); + END IF; + + IF V'LAST (N) /= 8 THEN + FAILED ("INCORRECT VALUE'LAST (N)"); + END IF; + + IF T'LENGTH /= 2 THEN + FAILED ("INCORRECT TYPE'LENGTH"); + END IF; + + IF X'LENGTH /= 2 THEN + FAILED ("INCORRECT OBJECT'LENGTH"); + END IF; + + IF V'LENGTH /= 2 THEN + FAILED ("INCORRECT VALUE'LENGTH"); + END IF; + + IF T'LENGTH (N) /= 3 THEN + FAILED ("INCORRECT TYPE'LENGTH (N)"); + END IF; + + IF X'LENGTH (N) /= 3 THEN + FAILED ("INCORRECT OBJECT'LENGTH (N)"); + END IF; + + IF V'LENGTH (N) /= 3 THEN + FAILED ("INCORRECT VALUE'LENGTH (N)"); + END IF; + + DECLARE + Y : PARENT (T'RANGE, 1 .. 3); + BEGIN + IF Y'FIRST /= 4 OR Y'LAST /= 5 THEN + FAILED ("INCORRECT TYPE'RANGE"); + END IF; + END; + + DECLARE + Y : PARENT (X'RANGE, 1 .. 3); + BEGIN + IF Y'FIRST /= 4 OR Y'LAST /= 5 THEN + FAILED ("INCORRECT OBJECT'RANGE"); + END IF; + END; + + DECLARE + Y : PARENT (V'RANGE, 1 .. 3); + BEGIN + IF Y'FIRST /= 4 OR Y'LAST /= 5 THEN + FAILED ("INCORRECT VALUE'RANGE"); + END IF; + END; + + DECLARE + Y : PARENT (1 .. 2, T'RANGE (N)); + BEGIN + IF Y'FIRST (N) /= 6 OR Y'LAST (N) /= 8 THEN + FAILED ("INCORRECT TYPE'RANGE (N)"); + END IF; + END; + + DECLARE + Y : PARENT (1 .. 2, X'RANGE (N)); + BEGIN + IF Y'FIRST (N) /= 6 OR Y'LAST (N) /= 8 THEN + FAILED ("INCORRECT OBJECT'RANGE (N)"); + END IF; + END; + + DECLARE + Y : PARENT (1 .. 2, V'RANGE (N)); + BEGIN + IF Y'FIRST (N) /= 6 OR Y'LAST (N) /= 8 THEN + FAILED ("INCORRECT VALUE'RANGE (N)"); + END IF; + END; + + IF T'SIZE < T'LENGTH * T'LENGTH (N) * COMPONENT'SIZE THEN + FAILED ("INCORRECT TYPE'SIZE"); + END IF; + + IF X'SIZE < X'LENGTH * X'LENGTH (N) * COMPONENT'SIZE THEN + FAILED ("INCORRECT OBJECT'SIZE"); + END IF; + + RESULT; +END C34005M; diff --git a/gcc-4.9/gcc/testsuite/ada/acats/tests/c3/c34005o.ada b/gcc-4.9/gcc/testsuite/ada/acats/tests/c3/c34005o.ada new file mode 100644 index 000000000..a45d5ddb2 --- /dev/null +++ b/gcc-4.9/gcc/testsuite/ada/acats/tests/c3/c34005o.ada @@ -0,0 +1,277 @@ +-- C34005O.ADA + +-- Grant of Unlimited Rights +-- +-- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687, +-- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained +-- unlimited rights in the software and documentation contained herein. +-- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making +-- this public release, the Government intends to confer upon all +-- recipients unlimited rights equal to those held by the Government. +-- These rights include rights to use, duplicate, release or disclose the +-- released technical data and computer software in whole or in part, in +-- any manner and for any purpose whatsoever, and to have or permit others +-- to do so. +-- +-- DISCLAIMER +-- +-- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR +-- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED +-- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE +-- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE +-- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A +-- PARTICULAR PURPOSE OF SAID MATERIAL. +--* +-- OBJECTIVE: +-- FOR DERIVED MULTI-DIMENSIONAL ARRAY TYPES WHOSE COMPONENT TYPE +-- IS A NON-LIMITED TYPE: +-- CHECK THAT ALL VALUES OF THE PARENT (BASE) TYPE ARE PRESENT FOR +-- THE DERIVED (BASE) TYPE WHEN THE DERIVED TYPE DEFINITION IS +-- CONSTRAINED. +-- CHECK THAT ANY CONSTRAINT IMPOSED ON THE PARENT SUBTYPE IS ALSO +-- IMPOSED ON THE DERIVED SUBTYPE. + +-- HISTORY: +-- JRK 9/17/86 CREATED ORIGINAL TEST. + +WITH REPORT; USE REPORT; + +PROCEDURE C34005O IS + + SUBTYPE COMPONENT IS INTEGER; + + PACKAGE PKG IS + + FIRST : CONSTANT := 0; + LAST : CONSTANT := 10; + + SUBTYPE INDEX IS INTEGER RANGE FIRST .. LAST; + + TYPE PARENT IS ARRAY (INDEX RANGE <>, INDEX RANGE <>) OF + COMPONENT; + + FUNCTION CREATE ( F1, L1 : INDEX; + F2, L2 : INDEX; + C : COMPONENT; + DUMMY : PARENT -- TO RESOLVE OVERLOADING. + ) RETURN PARENT; + + END PKG; + + USE PKG; + + TYPE T IS NEW PARENT (IDENT_INT (4) .. IDENT_INT (5), + IDENT_INT (6) .. IDENT_INT (8)); + + SUBTYPE SUBPARENT IS PARENT (4 .. 5, 6 .. 8); + + TYPE S IS NEW SUBPARENT; + + X : T := (OTHERS => (OTHERS => 2)); + Y : S := (OTHERS => (OTHERS => 2)); + + PACKAGE BODY PKG IS + + FUNCTION CREATE + ( F1, L1 : INDEX; + F2, L2 : INDEX; + C : COMPONENT; + DUMMY : PARENT + ) RETURN PARENT + IS + A : PARENT (F1 .. L1, F2 .. L2); + B : COMPONENT := C; + BEGIN + FOR I IN F1 .. L1 LOOP + FOR J IN F2 .. L2 LOOP + A (I, J) := B; + B := B + 1; + END LOOP; + END LOOP; + RETURN A; + END CREATE; + + END PKG; + +BEGIN + TEST ("C34005O", "CHECK THAT ALL VALUES OF THE PARENT (BASE) " & + "TYPE ARE PRESENT FOR THE DERIVED (BASE) TYPE " & + "WHEN THE DERIVED TYPE DEFINITION IS " & + "CONSTRAINED. ALSO CHECK THAT ANY CONSTRAINT " & + "IMPOSED ON THE PARENT SUBTYPE IS ALSO IMPOSED " & + "ON THE DERIVED SUBTYPE. CHECK FOR DERIVED " & + "MULTI-DIMENSIONAL ARRAY TYPES WHOSE COMPONENT " & + "TYPE IS A NON-LIMITED TYPE"); + + -- CHECK THAT BASE TYPE VALUES NOT IN THE SUBTYPE ARE PRESENT. + + BEGIN + IF CREATE (6, 9, 2, 3, 1, X) /= + ((1, 2), (3, 4), (5, 6), (7, 8)) OR + CREATE (6, 9, 2, 3, 1, Y) /= + ((1, 2), (3, 4), (5, 6), (7, 8)) THEN + FAILED ("CAN'T CREATE BASE TYPE VALUES OUTSIDE THE " & + "SUBTYPE"); + END IF; + EXCEPTION + WHEN CONSTRAINT_ERROR => + FAILED ("CALL TO CREATE RAISED CONSTRAINT_ERROR"); + WHEN OTHERS => + FAILED ("CALL TO CREATE RAISED EXCEPTION"); + END; + + IF ((1, 2), (3, 4), (5, 6), (7, 8)) IN T OR + ((1, 2), (3, 4), (5, 6), (7, 8)) IN S THEN + FAILED ("INCORRECT ""IN"""); + END IF; + + -- CHECK THE DERIVED SUBTYPE CONSTRAINT. + + IF T'FIRST /= 4 OR T'LAST /= 5 OR + S'FIRST /= 4 OR S'LAST /= 5 OR + T'FIRST (2) /= 6 OR T'LAST (2) /= 8 OR + S'FIRST (2) /= 6 OR S'LAST (2) /= 8 THEN + FAILED ("INCORRECT 'FIRST OR 'LAST"); + END IF; + + BEGIN + X := ((1, 2, 3), (4, 5, 6)); + Y := ((1, 2, 3), (4, 5, 6)); + IF PARENT (X) /= PARENT (Y) THEN -- USE X AND Y. + FAILED ("INCORRECT CONVERSION TO PARENT"); + END IF; + EXCEPTION + WHEN OTHERS => + FAILED ("EXCEPTION RAISED BY OK ASSIGNMENT"); + END; + + BEGIN + X := (4 => (6 .. 8 => 0)); + FAILED ("CONSTRAINT_ERROR NOT RAISED -- " & + "X := (4 => (6 .. 8 => 0))"); + IF X = (4 => (6 .. 8 => 0)) THEN -- USE X. + COMMENT ("X ALTERED -- " & + "X := (4 => (6 .. 8 => 0))"); + END IF; + EXCEPTION + WHEN CONSTRAINT_ERROR => + NULL; + WHEN OTHERS => + FAILED ("WRONG EXCEPTION RAISED -- " & + "X := (4 => (6 .. 8 => 0))"); + END; + + BEGIN + X := (4 .. 6 => (6 .. 8 => 0)); + FAILED ("CONSTRAINT_ERROR NOT RAISED -- " & + "X := (4 .. 6 => (6 .. 8 => 0))"); + IF X = (4 .. 6 => (6 .. 8 => 0)) THEN -- USE X. + COMMENT ("X ALTERED -- " & + "X := (4 .. 6 => (6 .. 8 => 0))"); + END IF; + EXCEPTION + WHEN CONSTRAINT_ERROR => + NULL; + WHEN OTHERS => + FAILED ("WRONG EXCEPTION RAISED -- " & + "X := (4 .. 6 => (6 .. 8 => 0))"); + END; + + BEGIN + X := (4 .. 5 => (6 .. 7 => 0)); + FAILED ("CONSTRAINT_ERROR NOT RAISED -- " & + "X := (4 .. 5 => (6 .. 7 => 0))"); + IF X = (4 .. 5 => (6 .. 7 => 0)) THEN -- USE X. + COMMENT ("X ALTERED -- " & + "X := (4 .. 5 => (6 .. 7 => 0))"); + END IF; + EXCEPTION + WHEN CONSTRAINT_ERROR => + NULL; + WHEN OTHERS => + FAILED ("WRONG EXCEPTION RAISED -- " & + "X := (4 .. 5 => (6 .. 7 => 0))"); + END; + + BEGIN + X := (4 .. 5 => (6 .. 9 => 0)); + FAILED ("CONSTRAINT_ERROR NOT RAISED -- " & + "X := (4 .. 5 => (6 .. 9 => 0))"); + IF X = (4 .. 5 => (6 .. 9 => 0)) THEN -- USE X. + COMMENT ("X ALTERED -- " & + "X := (4 .. 5 => (6 .. 9 => 0))"); + END IF; + EXCEPTION + WHEN CONSTRAINT_ERROR => + NULL; + WHEN OTHERS => + FAILED ("WRONG EXCEPTION RAISED -- " & + "X := (4 .. 5 => (6 .. 9 => 0))"); + END; + + BEGIN + Y := (4 => (6 .. 8 => 0)); + FAILED ("CONSTRAINT_ERROR NOT RAISED -- " & + "Y := (4 => (6 .. 8 => 0))"); + IF Y = (4 => (6 .. 8 => 0)) THEN -- USE Y. + COMMENT ("Y ALTERED -- " & + "Y := (4 => (6 .. 8 => 0))"); + END IF; + EXCEPTION + WHEN CONSTRAINT_ERROR => + NULL; + WHEN OTHERS => + FAILED ("WRONG EXCEPTION RAISED -- " & + "Y := (4 => (6 .. 8 => 0))"); + END; + + BEGIN + Y := (4 .. 6 => (6 .. 8 => 0)); + FAILED ("CONSTRAINT_ERROR NOT RAISED -- " & + "Y := (4 .. 6 => (6 .. 8 => 0))"); + IF Y = (4 .. 6 => (6 .. 8 => 0)) THEN -- USE Y. + COMMENT ("Y ALTERED -- " & + "Y := (4 .. 6 => (6 .. 8 => 0))"); + END IF; + EXCEPTION + WHEN CONSTRAINT_ERROR => + NULL; + WHEN OTHERS => + FAILED ("WRONG EXCEPTION RAISED -- " & + "Y := (4 .. 6 => (6 .. 8 => 0))"); + END; + + BEGIN + Y := (4 .. 5 => (6 .. 7 => 0)); + FAILED ("CONSTRAINT_ERROR NOT RAISED -- " & + "Y := (4 .. 5 => (6 .. 7 => 0))"); + IF Y = (4 .. 5 => (6 .. 7 => 0)) THEN -- USE Y. + COMMENT ("Y ALTERED -- " & + "Y := (4 .. 5 => (6 .. 7 => 0))"); + END IF; + EXCEPTION + WHEN CONSTRAINT_ERROR => + NULL; + WHEN OTHERS => + FAILED ("WRONG EXCEPTION RAISED -- " & + "Y := (4 .. 5 => (6 .. 7 => 0))"); + END; + + BEGIN + Y := (4 .. 5 => (6 .. 9 => 0)); + FAILED ("CONSTRAINT_ERROR NOT RAISED -- " & + "Y := (4 .. 5 => (6 .. 9 => 0))"); + IF Y = (4 .. 5 => (6 .. 9 => 0)) THEN -- USE Y. + COMMENT ("Y ALTERED -- " & + "Y := (4 .. 5 => (6 .. 9 => 0))"); + END IF; + EXCEPTION + WHEN CONSTRAINT_ERROR => + NULL; + WHEN OTHERS => + FAILED ("WRONG EXCEPTION RAISED -- " & + "Y := (4 .. 5 => (6 .. 9 => 0))"); + END; + + RESULT; +END C34005O; diff --git a/gcc-4.9/gcc/testsuite/ada/acats/tests/c3/c34005p.ada b/gcc-4.9/gcc/testsuite/ada/acats/tests/c3/c34005p.ada new file mode 100644 index 000000000..31e67a72e --- /dev/null +++ b/gcc-4.9/gcc/testsuite/ada/acats/tests/c3/c34005p.ada @@ -0,0 +1,405 @@ +-- C34005P.ADA + +-- Grant of Unlimited Rights +-- +-- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687, +-- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained +-- unlimited rights in the software and documentation contained herein. +-- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making +-- this public release, the Government intends to confer upon all +-- recipients unlimited rights equal to those held by the Government. +-- These rights include rights to use, duplicate, release or disclose the +-- released technical data and computer software in whole or in part, in +-- any manner and for any purpose whatsoever, and to have or permit others +-- to do so. +-- +-- DISCLAIMER +-- +-- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR +-- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED +-- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF 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 REQUIRED PREDEFINED OPERATIONS ARE DECLARED +-- (IMPLICITLY) FOR DERIVED ONE-DIMENSIONAL ARRAY TYPES WHOSE +-- COMPONENT TYPE IS A LIMITED TYPE. + +-- HISTORY: +-- JRK 08/17/87 CREATED ORIGINAL TEST. +-- VCL 07/01/88 MODIFIED THE STATEMENTS INVOLVING THE 'SIZE +-- ATTRIBUTE TO REMOVE ANY ASSUMPTIONS ABOUT THE +-- SIZES. ADDED EXCEPTION HANDLERS TO CATCH INCORRECT +-- TYPE CONVERSIONS TO DERIVED SUBTYPES. +-- PWN 11/30/94 REMOVED 'BASE USE ILLEGAL IN ADA 9X. +-- RLB 10/03/02 REMOVED ILLEGAL (BY AI-246) TYPE CONVERSIONS AND +-- SUPPORTING CODE. + +WITH SYSTEM; USE SYSTEM; +WITH REPORT; USE REPORT; + +PROCEDURE C34005P IS + + PACKAGE PKG_L IS + + TYPE LP IS LIMITED PRIVATE; + + FUNCTION CREATE (X : INTEGER) RETURN LP; + + FUNCTION VALUE (X : LP) RETURN INTEGER; + + FUNCTION EQUAL (X, Y : LP) RETURN BOOLEAN; + + PROCEDURE ASSIGN (X : OUT LP; Y : LP); + + C1 : CONSTANT LP; + C2 : CONSTANT LP; + C3 : CONSTANT LP; + C4 : CONSTANT LP; + C5 : CONSTANT LP; + C6 : CONSTANT LP; + + PRIVATE + + TYPE LP IS NEW INTEGER; + + C1 : CONSTANT LP := 1; + C2 : CONSTANT LP := 2; + C3 : CONSTANT LP := 3; + C4 : CONSTANT LP := 4; + C5 : CONSTANT LP := 5; + C6 : CONSTANT LP := 6; + + END PKG_L; + + USE PKG_L; + + SUBTYPE COMPONENT IS LP; + + PACKAGE PKG_P IS + + FIRST : CONSTANT := 0; + LAST : CONSTANT := 100; + + SUBTYPE INDEX IS INTEGER RANGE FIRST .. LAST; + + TYPE PARENT IS ARRAY (INDEX RANGE <>) OF COMPONENT; + + FUNCTION CREATE ( F, L : INDEX; + C : COMPONENT; + DUMMY : PARENT -- TO RESOLVE OVERLOADING. + ) RETURN PARENT; + + FUNCTION EQUAL (X, Y : PARENT) RETURN BOOLEAN; + + FUNCTION AGGR (X, Y : COMPONENT) RETURN PARENT; + + FUNCTION AGGR (X, Y, Z : COMPONENT) RETURN PARENT; + + END PKG_P; + + USE PKG_P; + + TYPE T IS NEW PARENT (IDENT_INT (5) .. IDENT_INT (7)); + + X : T; + W : PARENT (5 .. 7); + C : COMPONENT; + B : BOOLEAN := FALSE; + N : CONSTANT := 1; + + PROCEDURE A (X : ADDRESS) IS + BEGIN + B := IDENT_BOOL (TRUE); + END A; + + FUNCTION V RETURN T IS + RESULT : T; + BEGIN + FOR I IN RESULT'RANGE LOOP + ASSIGN (RESULT (I), C); + END LOOP; + RETURN RESULT; + END V; + + PACKAGE BODY PKG_L IS + + FUNCTION CREATE (X : INTEGER) RETURN LP IS + BEGIN + RETURN LP (IDENT_INT (X)); + END CREATE; + + FUNCTION VALUE (X : LP) RETURN INTEGER IS + BEGIN + RETURN INTEGER (X); + END VALUE; + + FUNCTION EQUAL (X, Y : LP) RETURN BOOLEAN IS + BEGIN + RETURN X = Y; + END EQUAL; + + PROCEDURE ASSIGN (X : OUT LP; Y : LP) IS + BEGIN + X := Y; + END ASSIGN; + + END PKG_L; + + PACKAGE BODY PKG_P IS + + FUNCTION CREATE + ( F, L : INDEX; + C : COMPONENT; + DUMMY : PARENT + ) RETURN PARENT + IS + A : PARENT (F .. L); + B : COMPONENT; + BEGIN + ASSIGN (B, C); + FOR I IN F .. L LOOP + ASSIGN (A (I), B); + ASSIGN (B, CREATE (VALUE (B) + 1)); + END LOOP; + RETURN A; + END CREATE; + + FUNCTION EQUAL (X, Y : PARENT) RETURN BOOLEAN IS + BEGIN + IF X'LENGTH /= Y'LENGTH THEN + RETURN FALSE; + ELSE FOR I IN X'RANGE LOOP + IF NOT EQUAL (X (I), + Y (I - X'FIRST + Y'FIRST)) THEN + RETURN FALSE; + END IF; + END LOOP; + END IF; + RETURN TRUE; + END EQUAL; + + FUNCTION AGGR (X, Y : COMPONENT) RETURN PARENT IS + RESULT : PARENT (INDEX'FIRST .. INDEX'FIRST + 1); + BEGIN + ASSIGN (RESULT (INDEX'FIRST ), X); + ASSIGN (RESULT (INDEX'FIRST + 1), Y); + RETURN RESULT; + END AGGR; + + FUNCTION AGGR (X, Y, Z : COMPONENT) RETURN PARENT IS + RESULT : PARENT (INDEX'FIRST .. INDEX'FIRST + 2); + BEGIN + ASSIGN (RESULT (INDEX'FIRST ), X); + ASSIGN (RESULT (INDEX'FIRST + 1), Y); + ASSIGN (RESULT (INDEX'FIRST + 2), Z); + RETURN RESULT; + END AGGR; + + END PKG_P; + +BEGIN + TEST ("C34005P", "CHECK THAT THE REQUIRED PREDEFINED OPERATIONS " & + "ARE DECLARED (IMPLICITLY) FOR DERIVED " & + "ONE-DIMENSIONAL ARRAY TYPES WHOSE COMPONENT " & + "TYPE IS A LIMITED TYPE"); + + ASSIGN (X (IDENT_INT (5)), CREATE (1)); + ASSIGN (X (IDENT_INT (6)), CREATE (2)); + ASSIGN (X (IDENT_INT (7)), CREATE (3)); + + ASSIGN (W (5), CREATE (1)); + ASSIGN (W (6), CREATE (2)); + ASSIGN (W (7), CREATE (3)); + + ASSIGN (C, CREATE (2)); + + IF NOT EQUAL (T'(X), AGGR (C1, C2, C3)) THEN + FAILED ("INCORRECT QUALIFICATION"); + END IF; + + IF NOT EQUAL (T(X), AGGR (C1, C2, C3)) THEN + FAILED ("INCORRECT SELF CONVERSION"); + END IF; + + IF NOT EQUAL (T(W), AGGR (C1, C2, C3)) THEN + FAILED ("INCORRECT CONVERSION FROM PARENT"); + END IF; + + IF NOT EQUAL (PARENT(X), AGGR (C1, C2, C3)) THEN + FAILED ("INCORRECT CONVERSION TO PARENT - 1"); + END IF; + + BEGIN + IF NOT EQUAL (PARENT(CREATE (2, 3, C4, X)), + AGGR (C4, C5)) THEN + FAILED ("INCORRECT CONVERSION TO PARENT - 2"); + END IF; + EXCEPTION + WHEN OTHERS => + FAILED ("EXCEPTION RAISED WHILE CHECKING BASE TYPE " & + "VALUES OUTSIDE OF THE SUBTYPE T - 1"); + END; + + IF NOT EQUAL (X(IDENT_INT (5)), C1) THEN + FAILED ("INCORRECT INDEX (VALUE)"); + END IF; + + BEGIN + IF NOT EQUAL (X(IDENT_INT (6)..IDENT_INT (7)), + AGGR (C2, C3)) OR + NOT EQUAL (CREATE (1, 4, C4, X)(1..3), + AGGR (C4, C5, C6)) THEN + FAILED ("INCORRECT SLICE (VALUE)"); + END IF; + EXCEPTION + WHEN OTHERS => + FAILED ("EXCEPTION RAISED WHILE CHECKING SLICES"); + END; + + IF NOT (X IN T) OR AGGR (C1, C2) IN T THEN + FAILED ("INCORRECT ""IN"""); + END IF; + + IF X NOT IN T OR NOT (AGGR (C1, C2) NOT IN T) THEN + FAILED ("INCORRECT ""NOT IN"""); + END IF; + + B := FALSE; + A (X'ADDRESS); + IF NOT B THEN + FAILED ("INCORRECT 'ADDRESS"); + END IF; + + IF T'FIRST /= 5 THEN + FAILED ("INCORRECT TYPE'FIRST"); + END IF; + + IF X'FIRST /= 5 THEN + FAILED ("INCORRECT OBJECT'FIRST"); + END IF; + + IF V'FIRST /= 5 THEN + FAILED ("INCORRECT VALUE'FIRST"); + END IF; + + IF T'FIRST (N) /= 5 THEN + FAILED ("INCORRECT TYPE'FIRST (N)"); + END IF; + + IF X'FIRST (N) /= 5 THEN + FAILED ("INCORRECT OBJECT'FIRST (N)"); + END IF; + + IF V'FIRST (N) /= 5 THEN + FAILED ("INCORRECT VALUE'FIRST (N)"); + END IF; + + IF T'LAST /= 7 THEN + FAILED ("INCORRECT TYPE'LAST"); + END IF; + + IF X'LAST /= 7 THEN + FAILED ("INCORRECT OBJECT'LAST"); + END IF; + + IF V'LAST /= 7 THEN + FAILED ("INCORRECT VALUE'LAST"); + END IF; + + IF T'LAST (N) /= 7 THEN + FAILED ("INCORRECT TYPE'LAST (N)"); + END IF; + + IF X'LAST (N) /= 7 THEN + FAILED ("INCORRECT OBJECT'LAST (N)"); + END IF; + + IF V'LAST (N) /= 7 THEN + FAILED ("INCORRECT VALUE'LAST (N)"); + END IF; + + IF T'LENGTH /= 3 THEN + FAILED ("INCORRECT TYPE'LENGTH"); + END IF; + + IF X'LENGTH /= 3 THEN + FAILED ("INCORRECT OBJECT'LENGTH"); + END IF; + + IF V'LENGTH /= 3 THEN + FAILED ("INCORRECT VALUE'LENGTH"); + END IF; + + IF T'LENGTH (N) /= 3 THEN + FAILED ("INCORRECT TYPE'LENGTH (N)"); + END IF; + + IF X'LENGTH (N) /= 3 THEN + FAILED ("INCORRECT OBJECT'LENGTH (N)"); + END IF; + + IF V'LENGTH (N) /= 3 THEN + FAILED ("INCORRECT VALUE'LENGTH (N)"); + END IF; + + DECLARE + Y : PARENT (T'RANGE); + BEGIN + IF Y'FIRST /= 5 OR Y'LAST /= 7 THEN + FAILED ("INCORRECT TYPE'RANGE"); + END IF; + END; + + DECLARE + Y : PARENT (X'RANGE); + BEGIN + IF Y'FIRST /= 5 OR Y'LAST /= 7 THEN + FAILED ("INCORRECT OBJECT'RANGE"); + END IF; + END; + + DECLARE + Y : PARENT (V'RANGE); + BEGIN + IF Y'FIRST /= 5 OR Y'LAST /= 7 THEN + FAILED ("INCORRECT VALUE'RANGE"); + END IF; + END; + + DECLARE + Y : PARENT (T'RANGE (N)); + BEGIN + IF Y'FIRST /= 5 OR Y'LAST /= 7 THEN + FAILED ("INCORRECT TYPE'RANGE (N)"); + END IF; + END; + + DECLARE + Y : PARENT (X'RANGE (N)); + BEGIN + IF Y'FIRST /= 5 OR Y'LAST /= 7 THEN + FAILED ("INCORRECT OBJECT'RANGE (N)"); + END IF; + END; + + DECLARE + Y : PARENT (V'RANGE (N)); + BEGIN + IF Y'FIRST /= 5 OR Y'LAST /= 7 THEN + FAILED ("INCORRECT VALUE'RANGE (N)"); + END IF; + END; + + IF X'SIZE < T'SIZE THEN + COMMENT ("X'SIZE < T'SIZE"); + ELSIF X'SIZE = T'SIZE THEN + COMMENT ("X'SIZE = T'SIZE"); + ELSE + COMMENT ("X'SIZE > T'SIZE"); + END IF; + + RESULT; +END C34005P; diff --git a/gcc-4.9/gcc/testsuite/ada/acats/tests/c3/c34005r.ada b/gcc-4.9/gcc/testsuite/ada/acats/tests/c3/c34005r.ada new file mode 100644 index 000000000..8b36d59a3 --- /dev/null +++ b/gcc-4.9/gcc/testsuite/ada/acats/tests/c3/c34005r.ada @@ -0,0 +1,346 @@ +-- C34005R.ADA + +-- Grant of Unlimited Rights +-- +-- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687, +-- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained +-- unlimited rights in the software and documentation contained herein. +-- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making +-- this public release, the Government intends to confer upon all +-- recipients unlimited rights equal to those held by the Government. +-- These rights include rights to use, duplicate, release or disclose the +-- released technical data and computer software in whole or in part, in +-- any manner and for any purpose whatsoever, and to have or permit others +-- to do so. +-- +-- DISCLAIMER +-- +-- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR +-- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED +-- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE +-- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE +-- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A +-- PARTICULAR PURPOSE OF SAID MATERIAL. +--* +-- OBJECTIVE: +-- FOR DERIVED ONE-DIMENSIONAL ARRAY TYPES WHOSE COMPONENT TYPE IS A +-- LIMITED TYPE: + +-- CHECK THAT ALL VALUES OF THE PARENT (BASE) TYPE ARE PRESENT +-- FOR THE DERIVED (BASE) TYPE WHEN THE DERIVED TYPE DEFINITION +-- IS CONSTRAINED. + +-- CHECK THAT ANY CONSTRAINT IMPOSED ON THE PARENT SUBTYPE IS +-- ALSO IMPOSED ON THE DERIVED SUBTYPE. + +-- HISTORY: +-- JRK 08/19/87 CREATED ORIGINAL TEST. +-- VCL 07/01/88 ADDED EXCEPTION HANDLERS TO CATCH INCORRECT TYPE +-- CONVERSIONS TO DERIVED SUBTYPES. + +WITH REPORT; USE REPORT; + +PROCEDURE C34005R IS + + PACKAGE PKG_L IS + + TYPE LP IS LIMITED PRIVATE; + + FUNCTION CREATE (X : INTEGER) RETURN LP; + + FUNCTION VALUE (X : LP) RETURN INTEGER; + + FUNCTION EQUAL (X, Y : LP) RETURN BOOLEAN; + + PROCEDURE ASSIGN (X : OUT LP; Y : LP); + + C1 : CONSTANT LP; + C2 : CONSTANT LP; + C3 : CONSTANT LP; + C4 : CONSTANT LP; + C5 : CONSTANT LP; + + PRIVATE + + TYPE LP IS NEW INTEGER; + + C1 : CONSTANT LP := 1; + C2 : CONSTANT LP := 2; + C3 : CONSTANT LP := 3; + C4 : CONSTANT LP := 4; + C5 : CONSTANT LP := 5; + + END PKG_L; + + USE PKG_L; + + SUBTYPE COMPONENT IS LP; + + PACKAGE PKG_P IS + + FIRST : CONSTANT := 0; + LAST : CONSTANT := 100; + + SUBTYPE INDEX IS INTEGER RANGE FIRST .. LAST; + + TYPE PARENT IS ARRAY (INDEX RANGE <>) OF COMPONENT; + + FUNCTION CREATE ( F, L : INDEX; + C : COMPONENT; + DUMMY : PARENT -- TO RESOLVE OVERLOADING. + ) RETURN PARENT; + + FUNCTION EQUAL (X, Y : PARENT) RETURN BOOLEAN; + + FUNCTION AGGR (X, Y : COMPONENT) RETURN PARENT; + + FUNCTION AGGR (W, X, Y, Z : COMPONENT) RETURN PARENT; + + END PKG_P; + + USE PKG_P; + + TYPE T IS NEW PARENT (IDENT_INT (5) .. IDENT_INT (7)); + + SUBTYPE SUBPARENT IS PARENT (5 .. 7); + + TYPE S IS NEW SUBPARENT; + + X : T; + Y : S; + + PACKAGE BODY PKG_L IS + + FUNCTION CREATE (X : INTEGER) RETURN LP IS + BEGIN + RETURN LP (IDENT_INT (X)); + END CREATE; + + FUNCTION VALUE (X : LP) RETURN INTEGER IS + BEGIN + RETURN INTEGER (X); + END VALUE; + + FUNCTION EQUAL (X, Y : LP) RETURN BOOLEAN IS + BEGIN + RETURN X = Y; + END EQUAL; + + PROCEDURE ASSIGN (X : OUT LP; Y : LP) IS + BEGIN + X := Y; + END ASSIGN; + + END PKG_L; + + PACKAGE BODY PKG_P IS + + FUNCTION CREATE + ( F, L : INDEX; + C : COMPONENT; + DUMMY : PARENT + ) RETURN PARENT + IS + A : PARENT (F .. L); + B : COMPONENT; + BEGIN + ASSIGN (B, C); + FOR I IN F .. L LOOP + ASSIGN (A (I), B); + ASSIGN (B, CREATE (VALUE (B) + 1)); + END LOOP; + RETURN A; + END CREATE; + + FUNCTION EQUAL (X, Y : PARENT) RETURN BOOLEAN IS + BEGIN + IF X'LENGTH /= Y'LENGTH THEN + RETURN FALSE; + ELSE FOR I IN X'RANGE LOOP + IF NOT EQUAL (X (I), + Y (I - X'FIRST + Y'FIRST)) THEN + RETURN FALSE; + END IF; + END LOOP; + END IF; + RETURN TRUE; + END EQUAL; + + FUNCTION AGGR (X, Y : COMPONENT) RETURN PARENT IS + RESULT : PARENT (INDEX'FIRST .. INDEX'FIRST + 1); + BEGIN + ASSIGN (RESULT (INDEX'FIRST ), X); + ASSIGN (RESULT (INDEX'FIRST + 1), Y); + RETURN RESULT; + END AGGR; + + FUNCTION AGGR (W, X, Y, Z : COMPONENT) RETURN PARENT IS + RESULT : PARENT (INDEX'FIRST .. INDEX'FIRST + 3); + BEGIN + ASSIGN (RESULT (INDEX'FIRST ), W); + ASSIGN (RESULT (INDEX'FIRST + 1), X); + ASSIGN (RESULT (INDEX'FIRST + 2), Y); + ASSIGN (RESULT (INDEX'FIRST + 3), Z); + RETURN RESULT; + END AGGR; + + END PKG_P; + + PROCEDURE ASSIGN (X : IN OUT T; Y : T) IS + BEGIN + FOR I IN X'RANGE LOOP + ASSIGN (X (I), Y (I)); + END LOOP; + END ASSIGN; + + PROCEDURE ASSIGN (X : IN OUT S; Y : S) IS + BEGIN + FOR I IN X'RANGE LOOP + ASSIGN (X (I), Y (I)); + END LOOP; + END ASSIGN; + +BEGIN + TEST ("C34005R", "CHECK THAT ALL VALUES OF THE PARENT (BASE) " & + "TYPE ARE PRESENT FOR THE DERIVED (BASE) TYPE " & + "WHEN THE DERIVED TYPE DEFINITION IS " & + "CONSTRAINED. ALSO CHECK THAT ANY CONSTRAINT " & + "IMPOSED ON THE PARENT SUBTYPE IS ALSO IMPOSED " & + "ON THE DERIVED SUBTYPE. CHECK FOR DERIVED " & + "ONE-DIMENSIONAL ARRAY TYPES WHOSE COMPONENT " & + "TYPE IS A LIMITED TYPE"); + + ASSIGN (X (IDENT_INT (5)), CREATE (2)); + ASSIGN (X (IDENT_INT (6)), CREATE (3)); + ASSIGN (X (IDENT_INT (7)), CREATE (4)); + + ASSIGN (Y (5), C2); + ASSIGN (Y (6), C3); + ASSIGN (Y (7), C4); + + -- CHECK THAT BASE TYPE VALUES NOT IN THE SUBTYPE ARE PRESENT. + + BEGIN + IF NOT EQUAL (CREATE (2, 3, C4, X), AGGR (C4, C5)) THEN + FAILED ("CANNOT CREATE BASE TYPE VALUES OUTSIDE " & + "OF THE SUBTYPE T"); + END IF; + EXCEPTION + WHEN OTHERS => + FAILED ("EXCEPTION RAISED WHILE CHECKING BASE TYPE " & + "VALUES OUTSIDE OF THE SUBTYPE T"); + END; + + BEGIN + IF NOT EQUAL (CREATE (2, 3, C4, Y), AGGR (C4, C5)) THEN + FAILED ("CANNOT CREATE BASE TYPE VALUES OUTSIDE " & + "OF THE SUBTYPE S"); + END IF; + EXCEPTION + WHEN OTHERS => + FAILED ("EXCEPTION RAISED WHILE CHECKING BASE TYPE " & + "VALUES OUTSIDE OF THE SUBTYPE S"); + END; + + BEGIN + IF NOT EQUAL (X(IDENT_INT (6)..IDENT_INT (7)), + AGGR (C3, C4)) THEN + FAILED ("INCORRECT SLICE OF X (VALUE)"); + END IF; + EXCEPTION + WHEN OTHERS => + FAILED ("EXCEPTION RAISED WHILE CHECKING SLICE OF X"); + END; + + BEGIN + IF NOT EQUAL (AGGR (C3, C4), + Y(IDENT_INT (6)..IDENT_INT (7))) THEN + FAILED ("INCORRECT SLICE OF Y (VALUE)"); + END IF; + EXCEPTION + WHEN OTHERS => + FAILED ("EXCEPTION RAISED WHILE CHECKING SLICE OF Y"); + END; + + -- CHECK THE DERIVED SUBTYPE CONSTRAINT. + + IF T'FIRST /= 5 OR T'LAST /= 7 OR + S'FIRST /= 5 OR S'LAST /= 7 THEN + FAILED ("INCORRECT 'FIRST OR 'LAST"); + END IF; + + BEGIN + ASSIGN (X, CREATE (5, 7, C1, X)); + ASSIGN (Y, CREATE (5, 7, C1, Y)); + IF NOT EQUAL (PARENT (X), PARENT (Y)) THEN -- USE X AND Y. + FAILED ("INCORRECT CONVERSION TO PARENT"); + END IF; + EXCEPTION + WHEN OTHERS => + FAILED ("EXCEPTION RAISED BY OK ASSIGN CALL"); + END; + + BEGIN + ASSIGN (X, AGGR (C1, C2)); + FAILED ("CONSTRAINT_ERROR NOT RAISED -- " & + "ASSIGN (X, AGGR (C1, C2))"); + IF EQUAL (X, AGGR (C1, C2)) THEN -- USE X. + COMMENT ("X ALTERED -- ASSIGN (X, AGGR (C1, C2))"); + END IF; + EXCEPTION + WHEN CONSTRAINT_ERROR => + NULL; + WHEN OTHERS => + FAILED ("WRONG EXCEPTION RAISED -- " & + "ASSIGN (X, AGGR (C1, C2))"); + END; + + BEGIN + ASSIGN (X, AGGR (C1, C2, C3, C4)); + FAILED ("CONSTRAINT_ERROR NOT RAISED -- " & + "ASSIGN (X, AGGR (C1, C2, C3, C4))"); + IF EQUAL (X, AGGR (C1, C2, C3, C4)) THEN -- USE X. + COMMENT ("X ALTERED -- " & + "ASSIGN (X, AGGR (C1, C2, C3, C4))"); + END IF; + EXCEPTION + WHEN CONSTRAINT_ERROR => + NULL; + WHEN OTHERS => + FAILED ("WRONG EXCEPTION RAISED -- " & + "ASSIGN (X, AGGR (C1, C2, C3, C4))"); + END; + + BEGIN + ASSIGN (Y, AGGR (C1, C2)); + FAILED ("CONSTRAINT_ERROR NOT RAISED -- " & + "ASSIGN (Y, AGGR (C1, C2))"); + IF EQUAL (Y, AGGR (C1, C2)) THEN -- USE Y. + COMMENT ("Y ALTERED -- ASSIGN (Y, AGGR (C1, C2))"); + END IF; + EXCEPTION + WHEN CONSTRAINT_ERROR => + NULL; + WHEN OTHERS => + FAILED ("WRONG EXCEPTION RAISED -- " & + "ASSIGN (Y, AGGR (C1, C2))"); + END; + + BEGIN + ASSIGN (Y, AGGR (C1, C2, C3, C4)); + FAILED ("CONSTRAINT_ERROR NOT RAISED -- " & + "ASSIGN (Y, AGGR (C1, C2, C3, C4))"); + IF EQUAL (Y, AGGR (C1, C2, C3, C4)) THEN -- USE Y. + COMMENT ("Y ALTERED -- " & + "ASSIGN (Y, AGGR (C1, C2, C3, C4))"); + END IF; + EXCEPTION + WHEN CONSTRAINT_ERROR => + NULL; + WHEN OTHERS => + FAILED ("WRONG EXCEPTION RAISED -- " & + "ASSIGN (Y, AGGR (C1, C2, C3, C4))"); + END; + + RESULT; +END C34005R; diff --git a/gcc-4.9/gcc/testsuite/ada/acats/tests/c3/c34005s.ada b/gcc-4.9/gcc/testsuite/ada/acats/tests/c3/c34005s.ada new file mode 100644 index 000000000..515816665 --- /dev/null +++ b/gcc-4.9/gcc/testsuite/ada/acats/tests/c3/c34005s.ada @@ -0,0 +1,404 @@ +-- C34005S.ADA + +-- Grant of Unlimited Rights +-- +-- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687, +-- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained +-- unlimited rights in the software and documentation contained herein. +-- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making +-- this public release, the Government intends to confer upon all +-- recipients unlimited rights equal to those held by the Government. +-- These rights include rights to use, duplicate, release or disclose the +-- released technical data and computer software in whole or in part, in +-- any manner and for any purpose whatsoever, and to have or permit others +-- to do so. +-- +-- DISCLAIMER +-- +-- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR +-- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED +-- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF 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 REQUIRED PREDEFINED OPERATIONS ARE DECLARED +-- (IMPLICITLY) FOR DERIVED MULTI-DIMENSIONAL ARRAY TYPES WHOSE +-- COMPONENT TYPE IS A LIMITED TYPE. THIS TEST IS PART 1 OF 2 +-- TESTS WHICH COVER THE OBJECTIVE. THE SECOND PART IS IN TEST +-- C34005V. + +-- HISTORY: +-- JRK 08/20/87 CREATED ORIGINAL TEST. +-- BCB 04/12/90 SPLIT ORIGINAL TEST INTO C34005S.ADA AND +-- C34005V.ADA +-- PWN 11/30/94 REMOVED 'BASE USE ILLEGAL IN ADA 9X. + +WITH SYSTEM; USE SYSTEM; +WITH REPORT; USE REPORT; + +PROCEDURE C34005S IS + + PACKAGE PKG_L IS + + TYPE LP IS LIMITED PRIVATE; + + FUNCTION CREATE (X : INTEGER) RETURN LP; + + FUNCTION VALUE (X : LP) RETURN INTEGER; + + FUNCTION EQUAL (X, Y : LP) RETURN BOOLEAN; + + PROCEDURE ASSIGN (X : OUT LP; Y : LP); + + C1 : CONSTANT LP; + C2 : CONSTANT LP; + C3 : CONSTANT LP; + C4 : CONSTANT LP; + C5 : CONSTANT LP; + C6 : CONSTANT LP; + C7 : CONSTANT LP; + C8 : CONSTANT LP; + C9 : CONSTANT LP; + C10 : CONSTANT LP; + C11 : CONSTANT LP; + C12 : CONSTANT LP; + C13 : CONSTANT LP; + C14 : CONSTANT LP; + + PRIVATE + + TYPE LP IS NEW INTEGER; + + C1 : CONSTANT LP := 1; + C2 : CONSTANT LP := 2; + C3 : CONSTANT LP := 3; + C4 : CONSTANT LP := 4; + C5 : CONSTANT LP := 5; + C6 : CONSTANT LP := 6; + C7 : CONSTANT LP := 7; + C8 : CONSTANT LP := 8; + C9 : CONSTANT LP := 9; + C10 : CONSTANT LP := 10; + C11 : CONSTANT LP := 11; + C12 : CONSTANT LP := 12; + C13 : CONSTANT LP := 13; + C14 : CONSTANT LP := 14; + + END PKG_L; + + USE PKG_L; + + SUBTYPE COMPONENT IS LP; + + PACKAGE PKG_P IS + + FIRST : CONSTANT := 0; + LAST : CONSTANT := 10; + + SUBTYPE INDEX IS INTEGER RANGE FIRST .. LAST; + + TYPE PARENT IS ARRAY (INDEX RANGE <>, INDEX RANGE <>) OF + COMPONENT; + + FUNCTION CREATE ( F1, L1 : INDEX; + F2, L2 : INDEX; + C : COMPONENT; + DUMMY : PARENT -- TO RESOLVE OVERLOADING. + ) RETURN PARENT; + + FUNCTION EQUAL (X, Y : PARENT) RETURN BOOLEAN; + + END PKG_P; + + USE PKG_P; + + TYPE T IS NEW PARENT (IDENT_INT (4) .. IDENT_INT (5), + IDENT_INT (6) .. IDENT_INT (8)); + + TYPE ARRT IS ARRAY (INTEGER RANGE <>, INTEGER RANGE <>) OF + COMPONENT; + + SUBTYPE ARR IS ARRT (8 .. 9, 2 .. 4); + + X : T; + W : PARENT (4 .. 5, 6 .. 8); + C : COMPONENT; + B : BOOLEAN := FALSE; + U : ARR; + N : CONSTANT := 2; + + PROCEDURE A (X : ADDRESS) IS + BEGIN + B := IDENT_BOOL (TRUE); + END A; + + FUNCTION V RETURN T IS + RESULT : T; + BEGIN + FOR I IN RESULT'RANGE LOOP + FOR J IN RESULT'RANGE(2) LOOP + ASSIGN (RESULT (I, J), C); + END LOOP; + END LOOP; + RETURN RESULT; + END V; + + PACKAGE BODY PKG_L IS + + FUNCTION CREATE (X : INTEGER) RETURN LP IS + BEGIN + RETURN LP (IDENT_INT (X)); + END CREATE; + + FUNCTION VALUE (X : LP) RETURN INTEGER IS + BEGIN + RETURN INTEGER (X); + END VALUE; + + FUNCTION EQUAL (X, Y : LP) RETURN BOOLEAN IS + BEGIN + RETURN X = Y; + END EQUAL; + + PROCEDURE ASSIGN (X : OUT LP; Y : LP) IS + BEGIN + X := Y; + END ASSIGN; + + END PKG_L; + + PACKAGE BODY PKG_P IS + + FUNCTION CREATE + ( F1, L1 : INDEX; + F2, L2 : INDEX; + C : COMPONENT; + DUMMY : PARENT + ) RETURN PARENT + IS + A : PARENT (F1 .. L1, F2 .. L2); + B : COMPONENT; + BEGIN + ASSIGN (B, C); + FOR I IN F1 .. L1 LOOP + FOR J IN F2 .. L2 LOOP + ASSIGN (A (I, J), B); + ASSIGN (B, CREATE (VALUE (B) + 1)); + END LOOP; + END LOOP; + RETURN A; + END CREATE; + + FUNCTION EQUAL (X, Y : PARENT) RETURN BOOLEAN IS + BEGIN + IF X'LENGTH /= Y'LENGTH OR + X'LENGTH(2) /= Y'LENGTH(2) THEN + RETURN FALSE; + ELSE FOR I IN X'RANGE LOOP + FOR J IN X'RANGE(2) LOOP + IF NOT EQUAL (X (I, J), + Y (I - X'FIRST + Y'FIRST, + J - X'FIRST(2) + + Y'FIRST(2))) THEN + RETURN FALSE; + END IF; + END LOOP; + END LOOP; + END IF; + RETURN TRUE; + END EQUAL; + + END PKG_P; + + FUNCTION EQUAL (X, Y : ARRT) RETURN BOOLEAN IS + BEGIN + IF X'LENGTH /= Y'LENGTH OR X'LENGTH(2) /= Y'LENGTH(2) THEN + RETURN FALSE; + ELSE FOR I IN X'RANGE LOOP + FOR J IN X'RANGE(2) LOOP + IF NOT EQUAL (X (I, J), + Y (I - X'FIRST + Y'FIRST, + J - X'FIRST(2) + + Y'FIRST(2))) THEN + RETURN FALSE; + END IF; + END LOOP; + END LOOP; + END IF; + RETURN TRUE; + END EQUAL; + +BEGIN + TEST ("C34005S", "CHECK THAT THE REQUIRED PREDEFINED OPERATIONS " & + "ARE DECLARED (IMPLICITLY) FOR DERIVED " & + "MULTI-DIMENSIONAL ARRAY TYPES WHOSE COMPONENT " & + "TYPE IS A LIMITED TYPE. THIS TEST IS PART " & + "1 OF 2 TESTS WHICH COVER THE OBJECTIVE. THE " & + "SECOND PART IS IN TEST C34005V"); + + ASSIGN (X (IDENT_INT (4), IDENT_INT (6)), CREATE (1)); + ASSIGN (X (IDENT_INT (4), IDENT_INT (7)), CREATE (2)); + ASSIGN (X (IDENT_INT (4), IDENT_INT (8)), CREATE (3)); + ASSIGN (X (IDENT_INT (5), IDENT_INT (6)), CREATE (4)); + ASSIGN (X (IDENT_INT (5), IDENT_INT (7)), CREATE (5)); + ASSIGN (X (IDENT_INT (5), IDENT_INT (8)), CREATE (6)); + + ASSIGN (W (4, 6), CREATE (1)); + ASSIGN (W (4, 7), CREATE (2)); + ASSIGN (W (4, 8), CREATE (3)); + ASSIGN (W (5, 6), CREATE (4)); + ASSIGN (W (5, 7), CREATE (5)); + ASSIGN (W (5, 8), CREATE (6)); + + ASSIGN (C, CREATE (2)); + + ASSIGN (U (8, 2), CREATE (1)); + ASSIGN (U (8, 3), CREATE (2)); + ASSIGN (U (8, 4), CREATE (3)); + ASSIGN (U (9, 2), CREATE (4)); + ASSIGN (U (9, 3), CREATE (5)); + ASSIGN (U (9, 4), CREATE (6)); + + IF NOT EQUAL (X (IDENT_INT (4), IDENT_INT (6)), C1) OR + NOT EQUAL (CREATE (6, 9, 2, 3, C4, X) (9, 3), C11) THEN + FAILED ("INCORRECT INDEX (VALUE)"); + END IF; + + B := FALSE; + A (X'ADDRESS); + IF NOT B THEN + FAILED ("INCORRECT 'ADDRESS"); + END IF; + + IF T'FIRST /= 4 THEN + FAILED ("INCORRECT TYPE'FIRST"); + END IF; + + IF X'FIRST /= 4 THEN + FAILED ("INCORRECT OBJECT'FIRST"); + END IF; + + IF V'FIRST /= 4 THEN + FAILED ("INCORRECT VALUE'FIRST"); + END IF; + + IF T'FIRST (N) /= 6 THEN + FAILED ("INCORRECT TYPE'FIRST (N)"); + END IF; + + IF X'FIRST (N) /= 6 THEN + FAILED ("INCORRECT OBJECT'FIRST (N)"); + END IF; + + IF V'FIRST (N) /= 6 THEN + FAILED ("INCORRECT VALUE'FIRST (N)"); + END IF; + + IF T'LAST /= 5 THEN + FAILED ("INCORRECT TYPE'LAST"); + END IF; + + IF X'LAST /= 5 THEN + FAILED ("INCORRECT OBJECT'LAST"); + END IF; + + IF V'LAST /= 5 THEN + FAILED ("INCORRECT VALUE'LAST"); + END IF; + + IF T'LAST (N) /= 8 THEN + FAILED ("INCORRECT TYPE'LAST (N)"); + END IF; + + IF X'LAST (N) /= 8 THEN + FAILED ("INCORRECT OBJECT'LAST (N)"); + END IF; + + IF V'LAST (N) /= 8 THEN + FAILED ("INCORRECT VALUE'LAST (N)"); + END IF; + + IF T'LENGTH /= 2 THEN + FAILED ("INCORRECT TYPE'LENGTH"); + END IF; + + IF X'LENGTH /= 2 THEN + FAILED ("INCORRECT OBJECT'LENGTH"); + END IF; + + IF V'LENGTH /= 2 THEN + FAILED ("INCORRECT VALUE'LENGTH"); + END IF; + + IF T'LENGTH (N) /= 3 THEN + FAILED ("INCORRECT TYPE'LENGTH (N)"); + END IF; + + IF X'LENGTH (N) /= 3 THEN + FAILED ("INCORRECT OBJECT'LENGTH (N)"); + END IF; + + IF V'LENGTH (N) /= 3 THEN + FAILED ("INCORRECT VALUE'LENGTH (N)"); + END IF; + + DECLARE + Y : PARENT (T'RANGE, 1 .. 3); + BEGIN + IF Y'FIRST /= 4 OR Y'LAST /= 5 THEN + FAILED ("INCORRECT TYPE'RANGE"); + END IF; + END; + + DECLARE + Y : PARENT (X'RANGE, 1 .. 3); + BEGIN + IF Y'FIRST /= 4 OR Y'LAST /= 5 THEN + FAILED ("INCORRECT OBJECT'RANGE"); + END IF; + END; + + DECLARE + Y : PARENT (V'RANGE, 1 .. 3); + BEGIN + IF Y'FIRST /= 4 OR Y'LAST /= 5 THEN + FAILED ("INCORRECT VALUE'RANGE"); + END IF; + END; + + DECLARE + Y : PARENT (1 .. 2, T'RANGE (N)); + BEGIN + IF Y'FIRST (N) /= 6 OR Y'LAST (N) /= 8 THEN + FAILED ("INCORRECT TYPE'RANGE (N)"); + END IF; + END; + + DECLARE + Y : PARENT (1 .. 2, X'RANGE (N)); + BEGIN + IF Y'FIRST (N) /= 6 OR Y'LAST (N) /= 8 THEN + FAILED ("INCORRECT OBJECT'RANGE (N)"); + END IF; + END; + + DECLARE + Y : PARENT (1 .. 2, V'RANGE (N)); + BEGIN + IF Y'FIRST (N) /= 6 OR Y'LAST (N) /= 8 THEN + FAILED ("INCORRECT VALUE'RANGE (N)"); + END IF; + END; + + IF T'SIZE < T'LENGTH * T'LENGTH (N) * COMPONENT'SIZE THEN + FAILED ("INCORRECT TYPE'SIZE"); + END IF; + + IF X'SIZE < X'LENGTH * X'LENGTH (N) * COMPONENT'SIZE THEN + FAILED ("INCORRECT OBJECT'SIZE"); + END IF; + + RESULT; +END C34005S; diff --git a/gcc-4.9/gcc/testsuite/ada/acats/tests/c3/c34005u.ada b/gcc-4.9/gcc/testsuite/ada/acats/tests/c3/c34005u.ada new file mode 100644 index 000000000..ed77f3bfa --- /dev/null +++ b/gcc-4.9/gcc/testsuite/ada/acats/tests/c3/c34005u.ada @@ -0,0 +1,408 @@ +-- C34005U.ADA + +-- Grant of Unlimited Rights +-- +-- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687, +-- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained +-- unlimited rights in the software and documentation contained herein. +-- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making +-- this public release, the Government intends to confer upon all +-- recipients unlimited rights equal to those held by the Government. +-- These rights include rights to use, duplicate, release or disclose the +-- released technical data and computer software in whole or in part, in +-- any manner and for any purpose whatsoever, and to have or permit others +-- to do so. +-- +-- DISCLAIMER +-- +-- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR +-- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED +-- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE +-- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE +-- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A +-- PARTICULAR PURPOSE OF SAID MATERIAL. +--* +-- OBJECTIVE: +-- FOR DERIVED MULTI-DIMENSIONAL ARRAY TYPES WHOSE COMPONENT TYPE IS +-- A LIMITED TYPE: + +-- CHECK THAT ALL VALUES OF THE PARENT (BASE) TYPE ARE PRESENT +-- FOR THE DERIVED (BASE) TYPE WHEN THE DERIVED TYPE DEFINITION +-- IS CONSTRAINED. + +-- CHECK THAT ANY CONSTRAINT IMPOSED ON THE PARENT SUBTYPE IS +-- ALSO IMPOSED ON THE DERIVED SUBTYPE. + +-- HISTORY: +-- JRK 08/21/87 CREATED ORIGINAL TEST. + +WITH REPORT; USE REPORT; + +PROCEDURE C34005U IS + + PACKAGE PKG_L IS + + TYPE LP IS LIMITED PRIVATE; + + FUNCTION CREATE (X : INTEGER) RETURN LP; + + FUNCTION VALUE (X : LP) RETURN INTEGER; + + FUNCTION EQUAL (X, Y : LP) RETURN BOOLEAN; + + PROCEDURE ASSIGN (X : OUT LP; Y : LP); + + C1 : CONSTANT LP; + C2 : CONSTANT LP; + C3 : CONSTANT LP; + C4 : CONSTANT LP; + C5 : CONSTANT LP; + C6 : CONSTANT LP; + C7 : CONSTANT LP; + C8 : CONSTANT LP; + + PRIVATE + + TYPE LP IS NEW INTEGER; + + C1 : CONSTANT LP := 1; + C2 : CONSTANT LP := 2; + C3 : CONSTANT LP := 3; + C4 : CONSTANT LP := 4; + C5 : CONSTANT LP := 5; + C6 : CONSTANT LP := 6; + C7 : CONSTANT LP := 7; + C8 : CONSTANT LP := 8; + + END PKG_L; + + USE PKG_L; + + SUBTYPE COMPONENT IS LP; + + PACKAGE PKG_P IS + + FIRST : CONSTANT := 0; + LAST : CONSTANT := 10; + + SUBTYPE INDEX IS INTEGER RANGE FIRST .. LAST; + + TYPE PARENT IS ARRAY (INDEX RANGE <>, INDEX RANGE <>) OF + COMPONENT; + + FUNCTION CREATE ( F1, L1 : INDEX; + F2, L2 : INDEX; + C : COMPONENT; + DUMMY : PARENT -- TO RESOLVE OVERLOADING. + ) RETURN PARENT; + + FUNCTION EQUAL (X, Y : PARENT) RETURN BOOLEAN; + + FUNCTION AGGR (A, B, C, D, E, F, G, H : COMPONENT) + RETURN PARENT; + + END PKG_P; + + USE PKG_P; + + TYPE T IS NEW PARENT (IDENT_INT (4) .. IDENT_INT (5), + IDENT_INT (6) .. IDENT_INT (8)); + + SUBTYPE SUBPARENT IS PARENT (4 .. 5, 6 .. 8); + + TYPE S IS NEW SUBPARENT; + + X : T; + Y : S; + + PACKAGE BODY PKG_L IS + + FUNCTION CREATE (X : INTEGER) RETURN LP IS + BEGIN + RETURN LP (IDENT_INT (X)); + END CREATE; + + FUNCTION VALUE (X : LP) RETURN INTEGER IS + BEGIN + RETURN INTEGER (X); + END VALUE; + + FUNCTION EQUAL (X, Y : LP) RETURN BOOLEAN IS + BEGIN + RETURN X = Y; + END EQUAL; + + PROCEDURE ASSIGN (X : OUT LP; Y : LP) IS + BEGIN + X := Y; + END ASSIGN; + + END PKG_L; + + PACKAGE BODY PKG_P IS + + FUNCTION CREATE + ( F1, L1 : INDEX; + F2, L2 : INDEX; + C : COMPONENT; + DUMMY : PARENT + ) RETURN PARENT + IS + A : PARENT (F1 .. L1, F2 .. L2); + B : COMPONENT; + BEGIN + ASSIGN (B, C); + FOR I IN F1 .. L1 LOOP + FOR J IN F2 .. L2 LOOP + ASSIGN (A (I, J), B); + ASSIGN (B, CREATE (VALUE (B) + 1)); + END LOOP; + END LOOP; + RETURN A; + END CREATE; + + FUNCTION EQUAL (X, Y : PARENT) RETURN BOOLEAN IS + BEGIN + IF X'LENGTH /= Y'LENGTH OR + X'LENGTH(2) /= Y'LENGTH(2) THEN + RETURN FALSE; + ELSE FOR I IN X'RANGE LOOP + FOR J IN X'RANGE(2) LOOP + IF NOT EQUAL (X (I, J), + Y (I - X'FIRST + Y'FIRST, + J - X'FIRST(2) + + Y'FIRST(2))) THEN + RETURN FALSE; + END IF; + END LOOP; + END LOOP; + END IF; + RETURN TRUE; + END EQUAL; + + FUNCTION AGGR (A, B, C, D, E, F, G, H : COMPONENT) + RETURN PARENT IS + X : PARENT (INDEX'FIRST .. INDEX'FIRST + 3, + INDEX'FIRST .. INDEX'FIRST + 1); + BEGIN + ASSIGN (X (INDEX'FIRST , INDEX'FIRST ), A); + ASSIGN (X (INDEX'FIRST , INDEX'FIRST + 1), B); + ASSIGN (X (INDEX'FIRST + 1, INDEX'FIRST ), C); + ASSIGN (X (INDEX'FIRST + 1, INDEX'FIRST + 1), D); + ASSIGN (X (INDEX'FIRST + 2, INDEX'FIRST ), E); + ASSIGN (X (INDEX'FIRST + 2, INDEX'FIRST + 1), F); + ASSIGN (X (INDEX'FIRST + 3, INDEX'FIRST ), G); + ASSIGN (X (INDEX'FIRST + 3, INDEX'FIRST + 1), H); + RETURN X; + END AGGR; + + END PKG_P; + + PROCEDURE ASSIGN (X : IN OUT T; Y : T) IS + BEGIN + FOR I IN X'RANGE LOOP + FOR J IN X'RANGE(2) LOOP + ASSIGN (X (I, J), Y (I, J)); + END LOOP; + END LOOP; + END ASSIGN; + + PROCEDURE ASSIGN (X : IN OUT S; Y : S) IS + BEGIN + FOR I IN X'RANGE LOOP + FOR J IN X'RANGE(2) LOOP + ASSIGN (X (I, J), Y (I, J)); + END LOOP; + END LOOP; + END ASSIGN; + +BEGIN + TEST ("C34005U", "CHECK THAT ALL VALUES OF THE PARENT (BASE) " & + "TYPE ARE PRESENT FOR THE DERIVED (BASE) TYPE " & + "WHEN THE DERIVED TYPE DEFINITION IS " & + "CONSTRAINED. ALSO CHECK THAT ANY CONSTRAINT " & + "IMPOSED ON THE PARENT SUBTYPE IS ALSO IMPOSED " & + "ON THE DERIVED SUBTYPE. CHECK FOR DERIVED " & + "MULTI-DIMENSIONAL ARRAY TYPES WHOSE COMPONENT " & + "TYPE IS A LIMITED TYPE"); + + FOR I IN X'RANGE LOOP + FOR J IN X'RANGE(2) LOOP + ASSIGN (X (I, J), C2); + ASSIGN (Y (I, J), C2); + END LOOP; + END LOOP; + + -- CHECK THAT BASE TYPE VALUES NOT IN THE SUBTYPE ARE PRESENT. + BEGIN + IF NOT EQUAL (CREATE (6, 9, 2, 3, C1, X), + AGGR (C1, C2, C3, C4, C5, C6, C7, C8)) OR + NOT EQUAL (CREATE (6, 9, 2, 3, C1, Y), + AGGR (C1, C2, C3, C4, C5, C6, C7, C8)) THEN + FAILED ("CAN'T CREATE BASE TYPE VALUES OUTSIDE THE " & + "SUBTYPE"); + END IF; + EXCEPTION + WHEN CONSTRAINT_ERROR => + FAILED ("CONSTRAINT_ERROR WHEN TRYING TO CREATE BASE " & + "TYPE VALUES OUTSIDE THE SUBTYPE"); + WHEN OTHERS => + FAILED ("EXCEPTION WHEN TRYING TO CREATE BASE TYPE " & + "VALUES OUTSIDE THE SUBTYPE"); + END; + + IF AGGR (C1, C2, C3, C4, C5, C6, C7, C8) IN T OR + AGGR (C1, C2, C3, C4, C5, C6, C7, C8) IN S THEN + FAILED ("INCORRECT ""IN"""); + END IF; + + -- CHECK THE DERIVED SUBTYPE CONSTRAINT. + + IF T'FIRST /= 4 OR T'LAST /= 5 OR + S'FIRST /= 4 OR S'LAST /= 5 OR + T'FIRST (2) /= 6 OR T'LAST (2) /= 8 OR + S'FIRST (2) /= 6 OR S'LAST (2) /= 8 THEN + FAILED ("INCORRECT 'FIRST OR 'LAST"); + END IF; + + BEGIN + ASSIGN (X, CREATE (4, 5, 6, 8, C1, X)); + ASSIGN (Y, CREATE (4, 5, 6, 8, C1, Y)); + IF NOT EQUAL (PARENT (X), PARENT (Y)) THEN -- USE X AND Y. + FAILED ("INCORRECT CONVERSION TO PARENT"); + END IF; + EXCEPTION + WHEN OTHERS => + FAILED ("EXCEPTION RAISED BY OK ASSIGN CALL"); + END; + + BEGIN + ASSIGN (X, CREATE (4, 4, 6, 8, C1, X)); + FAILED ("CONSTRAINT_ERROR NOT RAISED -- " & + "ASSIGN (X, CREATE (4, 4, 6, 8, C1, X))"); + IF EQUAL (X, CREATE (4, 4, 6, 8, C1, X)) THEN -- USE X. + COMMENT ("X ALTERED -- " & + "ASSIGN (X, CREATE (4, 4, 6, 8, C1, X))"); + END IF; + EXCEPTION + WHEN CONSTRAINT_ERROR => + NULL; + WHEN OTHERS => + FAILED ("WRONG EXCEPTION RAISED -- " & + "ASSIGN (X, CREATE (4, 4, 6, 8, C1, X))"); + END; + + BEGIN + ASSIGN (X, CREATE (4, 6, 6, 8, C1, X)); + FAILED ("CONSTRAINT_ERROR NOT RAISED -- " & + "ASSIGN (X, CREATE (4, 6, 6, 8, C1, X))"); + IF EQUAL (X, CREATE (4, 6, 6, 8, C1, X)) THEN -- USE X. + COMMENT ("X ALTERED -- " & + "ASSIGN (X, CREATE (4, 6, 6, 8, C1, X))"); + END IF; + EXCEPTION + WHEN CONSTRAINT_ERROR => + NULL; + WHEN OTHERS => + FAILED ("WRONG EXCEPTION RAISED -- " & + "ASSIGN (X, CREATE (4, 6, 6, 8, C1, X))"); + END; + + BEGIN + ASSIGN (X, CREATE (4, 5, 6, 7, C1, X)); + FAILED ("CONSTRAINT_ERROR NOT RAISED -- " & + "ASSIGN (X, CREATE (4, 5, 6, 7, C1, X))"); + IF EQUAL (X, CREATE (4, 5, 6, 7, C1, X)) THEN -- USE X. + COMMENT ("X ALTERED -- " & + "ASSIGN (X, CREATE (4, 5, 6, 7, C1, X))"); + END IF; + EXCEPTION + WHEN CONSTRAINT_ERROR => + NULL; + WHEN OTHERS => + FAILED ("WRONG EXCEPTION RAISED -- " & + "ASSIGN (X, CREATE (4, 5, 6, 7, C1, X))"); + END; + + BEGIN + ASSIGN (X, CREATE (4, 5, 6, 9, C1, X)); + FAILED ("CONSTRAINT_ERROR NOT RAISED -- " & + "ASSIGN (X, CREATE (4, 5, 6, 9, C1, X))"); + IF EQUAL (X, CREATE (4, 5, 6, 9, C1, X)) THEN -- USE X. + COMMENT ("X ALTERED -- " & + "ASSIGN (X, CREATE (4, 5, 6, 9, C1, X))"); + END IF; + EXCEPTION + WHEN CONSTRAINT_ERROR => + NULL; + WHEN OTHERS => + FAILED ("WRONG EXCEPTION RAISED -- " & + "ASSIGN (X, CREATE (4, 5, 6, 9, C1, X))"); + END; + + BEGIN + ASSIGN (Y, CREATE (4, 4, 6, 8, C1, Y)); + FAILED ("CONSTRAINT_ERROR NOT RAISED -- " & + "ASSIGN (Y, CREATE (4, 4, 6, 8, C1, Y))"); + IF EQUAL (Y, CREATE (4, 4, 6, 8, C1, Y)) THEN -- USE Y. + COMMENT ("Y ALTERED -- " & + "ASSIGN (Y, CREATE (4, 4, 6, 8, C1, Y))"); + END IF; + EXCEPTION + WHEN CONSTRAINT_ERROR => + NULL; + WHEN OTHERS => + FAILED ("WRONG EXCEPTION RAISED -- " & + "ASSIGN (Y, CREATE (4, 4, 6, 8, C1, Y))"); + END; + + BEGIN + ASSIGN (Y, CREATE (4, 6, 6, 8, C1, Y)); + FAILED ("CONSTRAINT_ERROR NOT RAISED -- " & + "ASSIGN (Y, CREATE (4, 6, 6, 8, C1, Y))"); + IF EQUAL (Y, CREATE (4, 6, 6, 8, C1, Y)) THEN -- USE Y. + COMMENT ("Y ALTERED -- " & + "ASSIGN (Y, CREATE (4, 6, 6, 8, C1, Y))"); + END IF; + EXCEPTION + WHEN CONSTRAINT_ERROR => + NULL; + WHEN OTHERS => + FAILED ("WRONG EXCEPTION RAISED -- " & + "ASSIGN (Y, CREATE (4, 6, 6, 8, C1, Y))"); + END; + + BEGIN + ASSIGN (Y, CREATE (4, 5, 6, 7, C1, Y)); + FAILED ("CONSTRAINT_ERROR NOT RAISED -- " & + "ASSIGN (Y, CREATE (4, 5, 6, 7, C1, Y))"); + IF EQUAL (Y, CREATE (4, 5, 6, 7, C1, Y)) THEN -- USE Y. + COMMENT ("Y ALTERED -- " & + "ASSIGN (Y, CREATE (4, 5, 6, 7, C1, Y))"); + END IF; + EXCEPTION + WHEN CONSTRAINT_ERROR => + NULL; + WHEN OTHERS => + FAILED ("WRONG EXCEPTION RAISED -- " & + "ASSIGN (Y, CREATE (4, 5, 6, 7, C1, Y))"); + END; + + BEGIN + ASSIGN (Y, CREATE (4, 5, 6, 9, C1, Y)); + FAILED ("CONSTRAINT_ERROR NOT RAISED -- " & + "ASSIGN (Y, CREATE (4, 5, 6, 9, C1, Y))"); + IF EQUAL (Y, CREATE (4, 5, 6, 9, C1, Y)) THEN -- USE Y. + COMMENT ("Y ALTERED -- " & + "ASSIGN (Y, CREATE (4, 5, 6, 9, C1, Y))"); + END IF; + EXCEPTION + WHEN CONSTRAINT_ERROR => + NULL; + WHEN OTHERS => + FAILED ("WRONG EXCEPTION RAISED -- " & + "ASSIGN (Y, CREATE (4, 5, 6, 9, C1, Y))"); + END; + + RESULT; +END C34005U; diff --git a/gcc-4.9/gcc/testsuite/ada/acats/tests/c3/c34005v.ada b/gcc-4.9/gcc/testsuite/ada/acats/tests/c3/c34005v.ada new file mode 100644 index 000000000..cb59125b4 --- /dev/null +++ b/gcc-4.9/gcc/testsuite/ada/acats/tests/c3/c34005v.ada @@ -0,0 +1,336 @@ +-- C34005V.ADA + +-- Grant of Unlimited Rights +-- +-- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687, +-- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained +-- unlimited rights in the software and documentation contained herein. +-- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making +-- this public release, the Government intends to confer upon all +-- recipients unlimited rights equal to those held by the Government. +-- These rights include rights to use, duplicate, release or disclose the +-- released technical data and computer software in whole or in part, in +-- any manner and for any purpose whatsoever, and to have or permit others +-- to do so. +-- +-- DISCLAIMER +-- +-- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR +-- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED +-- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF 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 REQUIRED PREDEFINED OPERATIONS ARE DECLARED +-- (IMPLICITLY) FOR DERIVED MULTI-DIMENSIONAL ARRAY TYPES WHOSE +-- COMPONENT TYPE IS A LIMITED TYPE. THIS TEST IS PART 2 OF 2 +-- TESTS WHICH COVER THE OBJECTIVE. THE FIRST PART IS IN TEST +-- C34005S. + +-- HISTORY: +-- BCB 04/12/90 CREATED ORIGINAL TEST FROM SPLIT OF C34005S.ADA. +-- RLB 10/03/02 REMOVED ILLEGAL (BY AI-246) TYPE CONVERSIONS AND +-- SUPPORTING CODE. + +WITH SYSTEM; USE SYSTEM; +WITH REPORT; USE REPORT; + +PROCEDURE C34005V IS + + PACKAGE PKG_L IS + + TYPE LP IS LIMITED PRIVATE; + + FUNCTION CREATE (X : INTEGER) RETURN LP; + + FUNCTION VALUE (X : LP) RETURN INTEGER; + + FUNCTION EQUAL (X, Y : LP) RETURN BOOLEAN; + + PROCEDURE ASSIGN (X : OUT LP; Y : LP); + + C1 : CONSTANT LP; + C2 : CONSTANT LP; + C3 : CONSTANT LP; + C4 : CONSTANT LP; + C5 : CONSTANT LP; + C6 : CONSTANT LP; + C7 : CONSTANT LP; + C8 : CONSTANT LP; + C9 : CONSTANT LP; + C10 : CONSTANT LP; + C11 : CONSTANT LP; + C12 : CONSTANT LP; + C13 : CONSTANT LP; + C14 : CONSTANT LP; + + PRIVATE + + TYPE LP IS NEW INTEGER; + + C1 : CONSTANT LP := 1; + C2 : CONSTANT LP := 2; + C3 : CONSTANT LP := 3; + C4 : CONSTANT LP := 4; + C5 : CONSTANT LP := 5; + C6 : CONSTANT LP := 6; + C7 : CONSTANT LP := 7; + C8 : CONSTANT LP := 8; + C9 : CONSTANT LP := 9; + C10 : CONSTANT LP := 10; + C11 : CONSTANT LP := 11; + C12 : CONSTANT LP := 12; + C13 : CONSTANT LP := 13; + C14 : CONSTANT LP := 14; + + END PKG_L; + + USE PKG_L; + + SUBTYPE COMPONENT IS LP; + + PACKAGE PKG_P IS + + FIRST : CONSTANT := 0; + LAST : CONSTANT := 10; + + SUBTYPE INDEX IS INTEGER RANGE FIRST .. LAST; + + TYPE PARENT IS ARRAY (INDEX RANGE <>, INDEX RANGE <>) OF + COMPONENT; + + FUNCTION CREATE ( F1, L1 : INDEX; + F2, L2 : INDEX; + C : COMPONENT; + DUMMY : PARENT -- TO RESOLVE OVERLOADING. + ) RETURN PARENT; + + FUNCTION EQUAL (X, Y : PARENT) RETURN BOOLEAN; + + FUNCTION AGGR (A, B, C, D : COMPONENT) RETURN PARENT; + + FUNCTION AGGR (A, B, C, D, E, F : COMPONENT) RETURN PARENT; + + FUNCTION AGGR (A, B, C, D, E, F, G, H : COMPONENT) + RETURN PARENT; + + FUNCTION AGGR (A, B, C, D, E, F, G, H, I : COMPONENT) + RETURN PARENT; + + END PKG_P; + + USE PKG_P; + + TYPE T IS NEW PARENT (IDENT_INT (4) .. IDENT_INT (5), + IDENT_INT (6) .. IDENT_INT (8)); + + X : T; + W : PARENT (4 .. 5, 6 .. 8); + C : COMPONENT; + B : BOOLEAN := FALSE; + N : CONSTANT := 2; + + PROCEDURE A (X : ADDRESS) IS + BEGIN + B := IDENT_BOOL (TRUE); + END A; + + FUNCTION V RETURN T IS + RESULT : T; + BEGIN + FOR I IN RESULT'RANGE LOOP + FOR J IN RESULT'RANGE(2) LOOP + ASSIGN (RESULT (I, J), C); + END LOOP; + END LOOP; + RETURN RESULT; + END V; + + PACKAGE BODY PKG_L IS + + FUNCTION CREATE (X : INTEGER) RETURN LP IS + BEGIN + RETURN LP (IDENT_INT (X)); + END CREATE; + + FUNCTION VALUE (X : LP) RETURN INTEGER IS + BEGIN + RETURN INTEGER (X); + END VALUE; + + FUNCTION EQUAL (X, Y : LP) RETURN BOOLEAN IS + BEGIN + RETURN X = Y; + END EQUAL; + + PROCEDURE ASSIGN (X : OUT LP; Y : LP) IS + BEGIN + X := Y; + END ASSIGN; + + END PKG_L; + + PACKAGE BODY PKG_P IS + + FUNCTION CREATE + ( F1, L1 : INDEX; + F2, L2 : INDEX; + C : COMPONENT; + DUMMY : PARENT + ) RETURN PARENT + IS + A : PARENT (F1 .. L1, F2 .. L2); + B : COMPONENT; + BEGIN + ASSIGN (B, C); + FOR I IN F1 .. L1 LOOP + FOR J IN F2 .. L2 LOOP + ASSIGN (A (I, J), B); + ASSIGN (B, CREATE (VALUE (B) + 1)); + END LOOP; + END LOOP; + RETURN A; + END CREATE; + + FUNCTION EQUAL (X, Y : PARENT) RETURN BOOLEAN IS + BEGIN + IF X'LENGTH /= Y'LENGTH OR + X'LENGTH(2) /= Y'LENGTH(2) THEN + RETURN FALSE; + ELSE FOR I IN X'RANGE LOOP + FOR J IN X'RANGE(2) LOOP + IF NOT EQUAL (X (I, J), + Y (I - X'FIRST + Y'FIRST, + J - X'FIRST(2) + + Y'FIRST(2))) THEN + RETURN FALSE; + END IF; + END LOOP; + END LOOP; + END IF; + RETURN TRUE; + END EQUAL; + + FUNCTION AGGR (A, B, C, D : COMPONENT) RETURN PARENT IS + X : PARENT (INDEX'FIRST .. INDEX'FIRST + 1, + INDEX'FIRST .. INDEX'FIRST + 1); + BEGIN + ASSIGN (X (INDEX'FIRST , INDEX'FIRST ), A); + ASSIGN (X (INDEX'FIRST , INDEX'FIRST + 1), B); + ASSIGN (X (INDEX'FIRST + 1, INDEX'FIRST ), C); + ASSIGN (X (INDEX'FIRST + 1, INDEX'FIRST + 1), D); + RETURN X; + END AGGR; + + FUNCTION AGGR (A, B, C, D, E, F : COMPONENT) RETURN PARENT IS + X : PARENT (INDEX'FIRST .. INDEX'FIRST + 1, + INDEX'FIRST .. INDEX'FIRST + 2); + BEGIN + ASSIGN (X (INDEX'FIRST , INDEX'FIRST ), A); + ASSIGN (X (INDEX'FIRST , INDEX'FIRST + 1), B); + ASSIGN (X (INDEX'FIRST , INDEX'FIRST + 2), C); + ASSIGN (X (INDEX'FIRST + 1, INDEX'FIRST ), D); + ASSIGN (X (INDEX'FIRST + 1, INDEX'FIRST + 1), E); + ASSIGN (X (INDEX'FIRST + 1, INDEX'FIRST + 2), F); + RETURN X; + END AGGR; + + FUNCTION AGGR (A, B, C, D, E, F, G, H : COMPONENT) + RETURN PARENT IS + X : PARENT (INDEX'FIRST .. INDEX'FIRST + 3, + INDEX'FIRST .. INDEX'FIRST + 1); + BEGIN + ASSIGN (X (INDEX'FIRST , INDEX'FIRST ), A); + ASSIGN (X (INDEX'FIRST , INDEX'FIRST + 1), B); + ASSIGN (X (INDEX'FIRST + 1, INDEX'FIRST ), C); + ASSIGN (X (INDEX'FIRST + 1, INDEX'FIRST + 1), D); + ASSIGN (X (INDEX'FIRST + 2, INDEX'FIRST ), E); + ASSIGN (X (INDEX'FIRST + 2, INDEX'FIRST + 1), F); + ASSIGN (X (INDEX'FIRST + 3, INDEX'FIRST ), G); + ASSIGN (X (INDEX'FIRST + 3, INDEX'FIRST + 1), H); + RETURN X; + END AGGR; + + FUNCTION AGGR (A, B, C, D, E, F, G, H, I : COMPONENT) + RETURN PARENT IS + X : PARENT (INDEX'FIRST .. INDEX'FIRST + 2, + INDEX'FIRST .. INDEX'FIRST + 2); + BEGIN + ASSIGN (X (INDEX'FIRST , INDEX'FIRST ), A); + ASSIGN (X (INDEX'FIRST , INDEX'FIRST + 1), B); + ASSIGN (X (INDEX'FIRST , INDEX'FIRST + 2), C); + ASSIGN (X (INDEX'FIRST + 1, INDEX'FIRST ), D); + ASSIGN (X (INDEX'FIRST + 1, INDEX'FIRST + 1), E); + ASSIGN (X (INDEX'FIRST + 1, INDEX'FIRST + 2), F); + ASSIGN (X (INDEX'FIRST + 2, INDEX'FIRST ), G); + ASSIGN (X (INDEX'FIRST + 2, INDEX'FIRST + 1), H); + ASSIGN (X (INDEX'FIRST + 2, INDEX'FIRST + 2), I); + RETURN X; + END AGGR; + + END PKG_P; + +BEGIN + TEST ("C34005V", "CHECK THAT THE REQUIRED PREDEFINED OPERATIONS " & + "ARE DECLARED (IMPLICITLY) FOR DERIVED " & + "MULTI-DIMENSIONAL ARRAY TYPES WHOSE COMPONENT " & + "TYPE IS A LIMITED TYPE. THIS TEST IS PART 2 " & + "OF 2 TESTS WHICH COVER THE OBJECTIVE. THE " & + "FIRST PART IS IN TEST C34005S"); + + ASSIGN (X (IDENT_INT (4), IDENT_INT (6)), CREATE (1)); + ASSIGN (X (IDENT_INT (4), IDENT_INT (7)), CREATE (2)); + ASSIGN (X (IDENT_INT (4), IDENT_INT (8)), CREATE (3)); + ASSIGN (X (IDENT_INT (5), IDENT_INT (6)), CREATE (4)); + ASSIGN (X (IDENT_INT (5), IDENT_INT (7)), CREATE (5)); + ASSIGN (X (IDENT_INT (5), IDENT_INT (8)), CREATE (6)); + + ASSIGN (W (4, 6), CREATE (1)); + ASSIGN (W (4, 7), CREATE (2)); + ASSIGN (W (4, 8), CREATE (3)); + ASSIGN (W (5, 6), CREATE (4)); + ASSIGN (W (5, 7), CREATE (5)); + ASSIGN (W (5, 8), CREATE (6)); + + ASSIGN (C, CREATE (2)); + + IF NOT EQUAL (T'(X), AGGR (C1, C2, C3, C4, C5, C6)) THEN + FAILED ("INCORRECT QUALIFICATION"); + END IF; + + IF NOT EQUAL (T (X), AGGR (C1, C2, C3, C4, C5, C6)) THEN + FAILED ("INCORRECT SELF CONVERSION"); + END IF; + + IF NOT EQUAL (T (W), AGGR (C1, C2, C3, C4, C5, C6)) THEN + FAILED ("INCORRECT CONVERSION FROM PARENT"); + END IF; + + BEGIN + IF NOT EQUAL (PARENT (X), AGGR (C1, C2, C3, C4, C5, C6)) OR + NOT EQUAL (PARENT (CREATE (6, 9, 2, 3, C4, X)), + AGGR (C4, C5, C6, C7, C8, C9, C10, C11)) THEN + FAILED ("INCORRECT CONVERSION TO PARENT"); + END IF; + EXCEPTION + WHEN CONSTRAINT_ERROR => + FAILED ("CONSTRAINT_ERROR WHEN PREPARING TO CONVERT " & + "TO PARENT"); + WHEN OTHERS => + FAILED ("EXCEPTION WHEN PREPARING TO CONVERT " & + "TO PARENT"); + END; + + IF NOT (X IN T) OR AGGR (C1, C2, C3, C4) IN T THEN + FAILED ("INCORRECT ""IN"""); + END IF; + + IF X NOT IN T OR + NOT (AGGR (C1, C2, C3, C4, C5, C6, C7, C8, C9) NOT IN T) THEN + FAILED ("INCORRECT ""NOT IN"""); + END IF; + + RESULT; +END C34005V; diff --git a/gcc-4.9/gcc/testsuite/ada/acats/tests/c3/c34006a.ada b/gcc-4.9/gcc/testsuite/ada/acats/tests/c3/c34006a.ada new file mode 100644 index 000000000..c5d4675e2 --- /dev/null +++ b/gcc-4.9/gcc/testsuite/ada/acats/tests/c3/c34006a.ada @@ -0,0 +1,151 @@ +-- C34006A.ADA + +-- Grant of Unlimited Rights +-- +-- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687, +-- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained +-- unlimited rights in the software and documentation contained herein. +-- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making +-- this public release, the Government intends to confer upon all +-- recipients unlimited rights equal to those held by the Government. +-- These rights include rights to use, duplicate, release or disclose the +-- released technical data and computer software in whole or in part, in +-- any manner and for any purpose whatsoever, and to have or permit others +-- to do so. +-- +-- DISCLAIMER +-- +-- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR +-- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED +-- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF 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 REQUIRED PREDEFINED OPERATIONS ARE DECLARED +-- (IMPLICITLY) FOR DERIVED RECORD TYPES WITHOUT DISCRIMINANTS +-- AND WITH NON-LIMITED COMPONENT TYPES. + +-- HISTORY: +-- JRK 09/22/86 CREATED ORIGINAL TEST. +-- BCB 09/26/88 REMOVED COMPARISONS INVOLVING SIZE. +-- PWN 11/30/94 REMOVED 'BASE USE ILLEGAL IN ADA 9X. + +WITH SYSTEM; USE SYSTEM; +WITH REPORT; USE REPORT; + +PROCEDURE C34006A IS + + SUBTYPE COMPONENT IS INTEGER; + + TYPE PARENT IS + RECORD + C : COMPONENT; + B : BOOLEAN := TRUE; + END RECORD; + + TYPE T IS NEW PARENT; + + X : T := (2, FALSE); + K : INTEGER := X'SIZE; + W : PARENT := (2, FALSE); + C : COMPONENT := 1; + B : BOOLEAN := FALSE; + + PROCEDURE A (X : ADDRESS) IS + BEGIN + B := IDENT_BOOL (TRUE); + END A; + + FUNCTION IDENT (X : T) RETURN T IS + BEGIN + IF EQUAL (X.C, X.C) THEN + RETURN X; -- ALWAYS EXECUTED. + END IF; + RETURN (-1, FALSE); + END IDENT; + +BEGIN + TEST ("C34006A", "CHECK THAT THE REQUIRED PREDEFINED OPERATIONS " & + "ARE DECLARED (IMPLICITLY) FOR DERIVED " & + "RECORD TYPES WITHOUT DISCRIMINANTS AND WITH " & + "NON-LIMITED COMPONENT TYPES"); + + X := IDENT ((1, TRUE)); + IF X /= (1, TRUE) THEN + FAILED ("INCORRECT :="); + END IF; + + IF T'(X) /= (1, TRUE) THEN + FAILED ("INCORRECT QUALIFICATION"); + END IF; + + IF T (X) /= (1, TRUE) THEN + FAILED ("INCORRECT SELF CONVERSION"); + END IF; + + IF EQUAL (3, 3) THEN + W := (1, TRUE); + END IF; + IF T (W) /= (1, TRUE) THEN + FAILED ("INCORRECT CONVERSION FROM PARENT"); + END IF; + + IF PARENT (X) /= (1, TRUE) THEN + FAILED ("INCORRECT CONVERSION TO PARENT"); + END IF; + + IF IDENT ((1, TRUE)) /= (1, TRUE) THEN + FAILED ("INCORRECT AGGREGATE"); + END IF; + + IF X.C /= 1 OR X.B /= TRUE THEN + FAILED ("INCORRECT SELECTION (VALUE)"); + END IF; + + X.C := IDENT_INT (3); + X.B := IDENT_BOOL (FALSE); + IF X /= (3, FALSE) THEN + FAILED ("INCORRECT SELECTION (ASSIGNMENT)"); + END IF; + + X := IDENT ((1, TRUE)); + IF X = IDENT ((1, FALSE)) THEN + FAILED ("INCORRECT ="); + END IF; + + IF X /= IDENT ((1, TRUE)) THEN + FAILED ("INCORRECT /="); + END IF; + + IF NOT (X IN T) THEN + FAILED ("INCORRECT ""IN"""); + END IF; + + IF X NOT IN T THEN + FAILED ("INCORRECT ""NOT IN"""); + END IF; + + B := FALSE; + A (X'ADDRESS); + IF NOT B THEN + FAILED ("INCORRECT 'ADDRESS"); + END IF; + + IF X.C'FIRST_BIT < 0 THEN + FAILED ("INCORRECT 'FIRST_BIT"); + END IF; + + IF X.C'LAST_BIT < 0 OR + X.C'LAST_BIT - X.C'FIRST_BIT + 1 /= X.C'SIZE THEN + FAILED ("INCORRECT 'LAST_BIT"); + END IF; + + IF X.C'POSITION < 0 THEN + FAILED ("INCORRECT 'POSITION"); + END IF; + + + RESULT; +END C34006A; diff --git a/gcc-4.9/gcc/testsuite/ada/acats/tests/c3/c34006d.ada b/gcc-4.9/gcc/testsuite/ada/acats/tests/c3/c34006d.ada new file mode 100644 index 000000000..614a830be --- /dev/null +++ b/gcc-4.9/gcc/testsuite/ada/acats/tests/c3/c34006d.ada @@ -0,0 +1,238 @@ +-- C34006D.ADA + +-- Grant of Unlimited Rights +-- +-- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687, +-- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained +-- unlimited rights in the software and documentation contained herein. +-- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making +-- this public release, the Government intends to confer upon all +-- recipients unlimited rights equal to those held by the Government. +-- These rights include rights to use, duplicate, release or disclose the +-- released technical data and computer software in whole or in part, in +-- any manner and for any purpose whatsoever, and to have or permit others +-- to do so. +-- +-- DISCLAIMER +-- +-- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR +-- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED +-- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF 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 REQUIRED PREDEFINED OPERATIONS ARE DECLARED +-- (IMPLICITLY) FOR DERIVED RECORD TYPES WITH DISCRIMINANTS AND WITH +-- NON-LIMITED COMPONENT TYPES. + +-- HISTORY: +-- JRK 09/22/86 CREATED ORIGINAL TEST. +-- BCB 11/13/87 CHANGED TEST SO AN OBJECT'S SIZE MAY BE LESS THAN +-- THAT OF ITS TYPE. +-- RJW 08/21/89 MODIFIED CHECKS FOR SIZE. +-- PWN 01/31/95 REMOVED INCONSISTENCIES WITH ADA 9X. + +WITH SYSTEM; USE SYSTEM; +WITH REPORT; USE REPORT; + +PROCEDURE C34006D IS + + SUBTYPE COMPONENT IS INTEGER; + + PACKAGE PKG IS + + MAX_LEN : CONSTANT := 10; + + SUBTYPE LENGTH IS NATURAL RANGE 0 .. MAX_LEN; + + TYPE PARENT (B : BOOLEAN := TRUE; L : LENGTH := 1) IS + RECORD + I : INTEGER; + CASE B IS + WHEN TRUE => + S : STRING (1 .. L); + C : COMPONENT; + WHEN FALSE => + F : FLOAT := 5.0; + END CASE; + END RECORD; + + FUNCTION CREATE ( B : BOOLEAN; + L : LENGTH; + I : INTEGER; + S : STRING; + C : COMPONENT; + F : FLOAT; + X : PARENT -- TO RESOLVE OVERLOADING. + ) RETURN PARENT; + + END PKG; + + USE PKG; + + TYPE T IS NEW PARENT (IDENT_BOOL (TRUE), IDENT_INT (3)); + + X : T := (TRUE, 3, 2, "AAA", 2); + W : PARENT := (TRUE, 3, 2, "AAA", 2); + C : COMPONENT := 1; + B : BOOLEAN := FALSE; + + PROCEDURE A (X : ADDRESS) IS + BEGIN + B := IDENT_BOOL (TRUE); + END A; + + PACKAGE BODY PKG IS + + FUNCTION CREATE + ( B : BOOLEAN; + L : LENGTH; + I : INTEGER; + S : STRING; + C : COMPONENT; + F : FLOAT; + X : PARENT + ) RETURN PARENT + IS + BEGIN + CASE B IS + WHEN TRUE => + RETURN (TRUE, L, I, S, C); + WHEN FALSE => + RETURN (FALSE, L, I, F); + END CASE; + END CREATE; + + END PKG; + + FUNCTION IDENT (X : T) RETURN T IS + BEGIN + IF EQUAL (X.I, X.I) THEN + RETURN X; -- ALWAYS EXECUTED. + END IF; + RETURN (TRUE, 3, -1, "---", -1); + END IDENT; + +BEGIN + TEST ("C34006D", "CHECK THAT THE REQUIRED PREDEFINED OPERATIONS " & + "ARE DECLARED (IMPLICITLY) FOR DERIVED " & + "RECORD TYPES WITH DISCRIMINANTS AND WITH " & + "NON-LIMITED COMPONENT TYPES"); + + X := IDENT ((TRUE, 3, 1, "ABC", 4)); + IF X /= (TRUE, 3, 1, "ABC", 4) THEN + FAILED ("INCORRECT :="); + END IF; + + IF T'(X) /= (TRUE, 3, 1, "ABC", 4) THEN + FAILED ("INCORRECT QUALIFICATION"); + END IF; + + IF T (X) /= (TRUE, 3, 1, "ABC", 4) THEN + FAILED ("INCORRECT SELF CONVERSION"); + END IF; + + IF EQUAL (3, 3) THEN + W := (TRUE, 3, 1, "ABC", 4); + END IF; + IF T (W) /= (TRUE, 3, 1, "ABC", 4) THEN + FAILED ("INCORRECT CONVERSION FROM PARENT"); + END IF; + + BEGIN + IF PARENT (X) /= (TRUE, 3, 1, "ABC", 4) OR + PARENT (CREATE (FALSE, 2, 3, "XX", 5, 6.0, X)) /= + (FALSE, 2, 3, 6.0) THEN + FAILED ("INCORRECT CONVERSION TO PARENT"); + END IF; + EXCEPTION + WHEN CONSTRAINT_ERROR => + FAILED ("CALL TO CREATE RAISED CONSTRAINT_ERROR - 1"); + WHEN OTHERS => + FAILED ("CALL TO CREATE RAISED EXCEPTION - 1"); + END; + + IF IDENT ((TRUE, 3, 1, "ABC", 4)) /= (TRUE, 3, 1, "ABC", 4) OR + X = (FALSE, 3, 1, 4.0) THEN + FAILED ("INCORRECT AGGREGATE"); + END IF; + + BEGIN + IF X.B /= TRUE OR X.L /= 3 OR + CREATE (FALSE, 2, 3, "XX", 5, 6.0, X) . B /= FALSE OR + CREATE (FALSE, 2, 3, "XX", 5, 6.0, X) . L /= 2 THEN + FAILED ("INCORRECT SELECTION (DISCRIMINANT)"); + END IF; + EXCEPTION + WHEN CONSTRAINT_ERROR => + FAILED ("CALL TO CREATE RAISED CONSTRAINT_ERROR - 2"); + WHEN OTHERS => + FAILED ("CALL TO CREATE RAISED EXCEPTION - 2"); + END; + + BEGIN + IF X.I /= 1 OR X.S /= "ABC" OR X.C /= 4 OR + CREATE (FALSE, 2, 3, "XX", 5, 6.0, X) . I /= 3 OR + CREATE (FALSE, 2, 3, "XX", 5, 6.0, X) . F /= 6.0 THEN + FAILED ("INCORRECT SELECTION (VALUE)"); + END IF; + EXCEPTION + WHEN CONSTRAINT_ERROR => + FAILED ("CALL TO CREATE RAISED CONSTRAINT_ERROR - 3"); + WHEN OTHERS => + FAILED ("CALL TO CREATE RAISED EXCEPTION - 3"); + END; + + X.I := IDENT_INT (7); + X.S := IDENT_STR ("XYZ"); + X.C := IDENT_INT (9); + IF X /= (TRUE, 3, 7, "XYZ", 9) THEN + FAILED ("INCORRECT SELECTION (ASSIGNMENT)"); + END IF; + + X := IDENT ((TRUE, 3, 1, "ABC", 4)); + IF X = IDENT ((TRUE, 3, 1, "ABC", 5)) OR + X = (FALSE, 2, 3, 6.0) THEN + FAILED ("INCORRECT ="); + END IF; + + IF X /= IDENT ((TRUE, 3, 1, "ABC", 4)) OR + NOT (X /= (FALSE, 2, 3, 6.0)) THEN + FAILED ("INCORRECT /="); + END IF; + + IF NOT (X IN T) OR (FALSE, 2, 3, 6.0) IN T THEN + FAILED ("INCORRECT ""IN"""); + END IF; + + IF X NOT IN T OR NOT ((FALSE, 2, 3, 6.0) NOT IN T) THEN + FAILED ("INCORRECT ""NOT IN"""); + END IF; + + B := FALSE; + A (X'ADDRESS); + IF NOT B THEN + FAILED ("INCORRECT 'ADDRESS"); + END IF; + + IF NOT X'CONSTRAINED THEN + FAILED ("INCORRECT 'CONSTRAINED"); + END IF; + + IF X.C'FIRST_BIT < 0 THEN + FAILED ("INCORRECT 'FIRST_BIT"); + END IF; + + IF X.C'LAST_BIT < 0 OR + X.C'LAST_BIT - X.C'FIRST_BIT + 1 /= X.C'SIZE THEN + FAILED ("INCORRECT 'LAST_BIT"); + END IF; + + IF X.C'POSITION < 0 THEN + FAILED ("INCORRECT 'POSITION"); + END IF; + + RESULT; +END C34006D; diff --git a/gcc-4.9/gcc/testsuite/ada/acats/tests/c3/c34006f.ada b/gcc-4.9/gcc/testsuite/ada/acats/tests/c3/c34006f.ada new file mode 100644 index 000000000..3ee3745ac --- /dev/null +++ b/gcc-4.9/gcc/testsuite/ada/acats/tests/c3/c34006f.ada @@ -0,0 +1,228 @@ +-- C34006F.ADA + +-- Grant of Unlimited Rights +-- +-- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687, +-- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained +-- unlimited rights in the software and documentation contained herein. +-- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making +-- this public release, the Government intends to confer upon all +-- recipients unlimited rights equal to those held by the Government. +-- These rights include rights to use, duplicate, release or disclose the +-- released technical data and computer software in whole or in part, in +-- any manner and for any purpose whatsoever, and to have or permit others +-- to do so. +-- +-- DISCLAIMER +-- +-- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR +-- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED +-- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE +-- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE +-- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A +-- PARTICULAR PURPOSE OF SAID MATERIAL. +--* +-- OBJECTIVE: +-- FOR DERIVED RECORD TYPES WITH DISCRIMINANTS AND WITH NON-LIMITED +-- COMPONENT TYPES: +-- CHECK THAT ALL VALUES OF THE PARENT (BASE) TYPE ARE PRESENT FOR +-- THE DERIVED (BASE) TYPE WHEN THE DERIVED TYPE DEFINITION IS +-- CONSTRAINED. +-- CHECK THAT ANY CONSTRAINT IMPOSED ON THE PARENT SUBTYPE IS ALSO +-- IMPOSED ON THE DERIVED SUBTYPE. + +-- HISTORY: +-- JRK 9/22/86 CREATED ORIGINAL TEST. + +WITH REPORT; USE REPORT; + +PROCEDURE C34006F IS + + SUBTYPE COMPONENT IS INTEGER; + + PACKAGE PKG IS + + MAX_LEN : CONSTANT := 10; + + SUBTYPE LENGTH IS NATURAL RANGE 0 .. MAX_LEN; + + TYPE PARENT (B : BOOLEAN := TRUE; L : LENGTH := 1) IS + RECORD + I : INTEGER; + CASE B IS + WHEN TRUE => + S : STRING (1 .. L); + C : COMPONENT; + WHEN FALSE => + F : FLOAT := 5.0; + END CASE; + END RECORD; + + FUNCTION CREATE ( B : BOOLEAN; + L : LENGTH; + I : INTEGER; + S : STRING; + C : COMPONENT; + F : FLOAT; + X : PARENT -- TO RESOLVE OVERLOADING. + ) RETURN PARENT; + + END PKG; + + USE PKG; + + TYPE T IS NEW PARENT (IDENT_BOOL (TRUE), IDENT_INT (3)); + + SUBTYPE SUBPARENT IS PARENT (TRUE, 3); + + TYPE S IS NEW SUBPARENT; + + X : T := (TRUE, 3, 2, "AAA", 2); + Y : S := (TRUE, 3, 2, "AAA", 2); + + PACKAGE BODY PKG IS + + FUNCTION CREATE + ( B : BOOLEAN; + L : LENGTH; + I : INTEGER; + S : STRING; + C : COMPONENT; + F : FLOAT; + X : PARENT + ) RETURN PARENT + IS + BEGIN + CASE B IS + WHEN TRUE => + RETURN (TRUE, L, I, S, C); + WHEN FALSE => + RETURN (FALSE, L, I, F); + END CASE; + END CREATE; + + END PKG; + +BEGIN + TEST ("C34006F", "CHECK THAT ALL VALUES OF THE PARENT (BASE) " & + "TYPE ARE PRESENT FOR THE DERIVED (BASE) TYPE " & + "WHEN THE DERIVED TYPE DEFINITION IS " & + "CONSTRAINED. ALSO CHECK THAT ANY CONSTRAINT " & + "IMPOSED ON THE PARENT SUBTYPE IS ALSO IMPOSED " & + "ON THE DERIVED SUBTYPE. CHECK FOR DERIVED " & + "RECORD TYPES WITH DISCRIMINANTS AND WITH " & + "NON-LIMITED COMPONENT TYPES"); + + -- CHECK THAT BASE TYPE VALUES NOT IN THE SUBTYPE ARE PRESENT. + + BEGIN + IF CREATE (FALSE, 2, 3, "ZZ", 5, 6.0, X) /= + (FALSE, 2, 3, 6.0) OR + CREATE (FALSE, 2, 3, "ZZ", 5, 6.0, Y) /= + (FALSE, 2, 3, 6.0) THEN + FAILED ("CAN'T CREATE BASE TYPE VALUES OUTSIDE THE " & + "SUBTYPE"); + END IF; + EXCEPTION + WHEN CONSTRAINT_ERROR => + FAILED ("CALL TO CREATE RAISED CONSTRAINT_ERROR - 1"); + WHEN OTHERS => + FAILED ("CALL TO CREATE RAISED EXCEPTION - 1"); + END; + + BEGIN + IF CREATE (FALSE, 2, 3, "ZZ", 5, 6.0, X) IN T OR + CREATE (FALSE, 2, 3, "ZZ", 5, 6.0, Y) IN S THEN + FAILED ("INCORRECT ""IN"""); + END IF; + EXCEPTION + WHEN CONSTRAINT_ERROR => + FAILED ("CALL TO CREATE RAISED CONSTRAINT_ERROR - 2"); + WHEN OTHERS => + FAILED ("CALL TO CREATE RAISED EXCEPTION - 2"); + END; + + -- CHECK THE DERIVED SUBTYPE CONSTRAINT. + + IF X.B /= TRUE OR X.L /= 3 OR + Y.B /= TRUE OR Y.L /= 3 THEN + FAILED ("INCORRECT SELECTION OF DISCRIMINANT VALUES"); + END IF; + + IF NOT X'CONSTRAINED OR NOT Y'CONSTRAINED THEN + FAILED ("INCORRECT 'CONSTRAINED"); + END IF; + + BEGIN + X := (TRUE, 3, 1, "ABC", 4); + Y := (TRUE, 3, 1, "ABC", 4); + IF PARENT (X) /= PARENT (Y) THEN -- USE X AND Y. + FAILED ("INCORRECT CONVERSION TO PARENT"); + END IF; + EXCEPTION + WHEN OTHERS => + FAILED ("EXCEPTION RAISED BY OK ASSIGNMENT"); + END; + + BEGIN + X := (FALSE, 3, 2, 6.0); + FAILED ("CONSTRAINT_ERROR NOT RAISED -- " & + "X := (FALSE, 3, 2, 6.0)"); + IF X = (FALSE, 3, 2, 6.0) THEN -- USE X. + COMMENT ("X ALTERED -- X := (FALSE, 3, 2, 6.0)"); + END IF; + EXCEPTION + WHEN CONSTRAINT_ERROR => + NULL; + WHEN OTHERS => + FAILED ("WRONG EXCEPTION RAISED -- " & + "X := (FALSE, 3, 2, 6.0)"); + END; + + BEGIN + X := (TRUE, 4, 2, "ZZZZ", 6); + FAILED ("CONSTRAINT_ERROR NOT RAISED -- " & + "X := (TRUE, 4, 2, ""ZZZZ"", 6)"); + IF X = (TRUE, 4, 2, "ZZZZ", 6) THEN -- USE X. + COMMENT ("X ALTERED -- X := (TRUE, 4, 2, ""ZZZZ"", 6)"); + END IF; + EXCEPTION + WHEN CONSTRAINT_ERROR => + NULL; + WHEN OTHERS => + FAILED ("WRONG EXCEPTION RAISED -- " & + "X := (TRUE, 4, 2, ""ZZZZ"", 6)"); + END; + + BEGIN + Y := (FALSE, 3, 2, 6.0); + FAILED ("CONSTRAINT_ERROR NOT RAISED -- " & + "Y := (FALSE, 3, 2, 6.0)"); + IF Y = (FALSE, 3, 2, 6.0) THEN -- USE Y. + COMMENT ("Y ALTERED -- Y := (FALSE, 3, 2, 6.0)"); + END IF; + EXCEPTION + WHEN CONSTRAINT_ERROR => + NULL; + WHEN OTHERS => + FAILED ("WRONG EXCEPTION RAISED -- " & + "Y := (FALSE, 3, 2, 6.0)"); + END; + + BEGIN + Y := (TRUE, 4, 2, "ZZZZ", 6); + FAILED ("CONSTRAINT_ERROR NOT RAISED -- " & + "Y := (TRUE, 4, 2, ""ZZZZ"", 6)"); + IF Y = (TRUE, 4, 2, "ZZZZ", 6) THEN -- USE Y. + COMMENT ("Y ALTERED -- Y := (TRUE, 4, 2, ""ZZZZ"", 6)"); + END IF; + EXCEPTION + WHEN CONSTRAINT_ERROR => + NULL; + WHEN OTHERS => + FAILED ("WRONG EXCEPTION RAISED -- " & + "Y := (TRUE, 4, 2, ""ZZZZ"", 6)"); + END; + + RESULT; +END C34006F; diff --git a/gcc-4.9/gcc/testsuite/ada/acats/tests/c3/c34006g.ada b/gcc-4.9/gcc/testsuite/ada/acats/tests/c3/c34006g.ada new file mode 100644 index 000000000..ebb6c51ed --- /dev/null +++ b/gcc-4.9/gcc/testsuite/ada/acats/tests/c3/c34006g.ada @@ -0,0 +1,199 @@ +-- C34006G.ADA + +-- Grant of Unlimited Rights +-- +-- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687, +-- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained +-- unlimited rights in the software and documentation contained herein. +-- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making +-- this public release, the Government intends to confer upon all +-- recipients unlimited rights equal to those held by the Government. +-- These rights include rights to use, duplicate, release or disclose the +-- released technical data and computer software in whole or in part, in +-- any manner and for any purpose whatsoever, and to have or permit others +-- to do so. +-- +-- DISCLAIMER +-- +-- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR +-- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED +-- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF 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 REQUIRED PREDEFINED OPERATIONS ARE DECLARED +-- (IMPLICITLY) FOR DERIVED RECORD TYPES WITHOUT DISCRIMINANTS AND +-- WITH A LIMITED COMPONENT TYPE. + +-- HISTORY: +-- JRK 08/24/87 CREATED ORIGINAL TEST. +-- PWN 11/30/94 REMOVED 'BASE USE ILLEGAL IN ADA 9X. +-- PWN 01/31/95 REMOVED INCONSISTENCIES WITH ADA 9X. + +WITH SYSTEM; USE SYSTEM; +WITH REPORT; USE REPORT; + +PROCEDURE C34006G IS + + PACKAGE PKG_L IS + + TYPE LP IS LIMITED PRIVATE; + + FUNCTION CREATE (X : INTEGER) RETURN LP; + + FUNCTION EQUAL (X, Y : LP) RETURN BOOLEAN; + + PROCEDURE ASSIGN (X : OUT LP; Y : LP); + + C1 : CONSTANT LP; + + PRIVATE + + TYPE LP IS NEW INTEGER; + + C1 : CONSTANT LP := 1; + + END PKG_L; + + USE PKG_L; + + SUBTYPE COMPONENT IS LP; + + PACKAGE PKG_P IS + + TYPE PARENT IS + RECORD + C : COMPONENT; + B : BOOLEAN := TRUE; + END RECORD; + + FUNCTION EQUAL (X, Y : PARENT) RETURN BOOLEAN; + + FUNCTION AGGR (C : COMPONENT; B : BOOLEAN) RETURN PARENT; + + END PKG_P; + + USE PKG_P; + + TYPE T IS NEW PARENT; + + X : T; + W : PARENT; + B : BOOLEAN := FALSE; + + PROCEDURE A (X : ADDRESS) IS + BEGIN + B := IDENT_BOOL (TRUE); + END A; + + PACKAGE BODY PKG_L IS + + FUNCTION CREATE (X : INTEGER) RETURN LP IS + BEGIN + RETURN LP (IDENT_INT (X)); + END CREATE; + + FUNCTION EQUAL (X, Y : LP) RETURN BOOLEAN IS + BEGIN + RETURN X = Y; + END EQUAL; + + PROCEDURE ASSIGN (X : OUT LP; Y : LP) IS + BEGIN + X := Y; + END ASSIGN; + + END PKG_L; + + PACKAGE BODY PKG_P IS + + FUNCTION EQUAL (X, Y : PARENT) RETURN BOOLEAN IS + BEGIN + RETURN EQUAL (X.C, Y.C) AND X.B = Y.B; + END EQUAL; + + FUNCTION AGGR (C : COMPONENT; B : BOOLEAN) RETURN PARENT IS + RESULT : PARENT; + BEGIN + ASSIGN (RESULT.C, C); + RESULT.B := B; + RETURN RESULT; + END AGGR; + + END PKG_P; + +BEGIN + TEST ("C34006G", "CHECK THAT THE REQUIRED PREDEFINED OPERATIONS " & + "ARE DECLARED (IMPLICITLY) FOR DERIVED " & + "RECORD TYPES WITHOUT DISCRIMINANTS AND WITH A " & + "LIMITED COMPONENT TYPE"); + + ASSIGN (X.C, CREATE (1)); + X.B := IDENT_BOOL (TRUE); + + ASSIGN (W.C, CREATE (1)); + W.B := IDENT_BOOL (TRUE); + + IF NOT EQUAL (T'(X), AGGR (C1, TRUE)) THEN + FAILED ("INCORRECT QUALIFICATION"); + END IF; + + IF NOT EQUAL (T (X), AGGR (C1, TRUE)) THEN + FAILED ("INCORRECT SELF CONVERSION"); + END IF; + + IF NOT EQUAL (T (W), AGGR (C1, TRUE)) THEN + FAILED ("INCORRECT CONVERSION FROM PARENT"); + END IF; + + IF NOT EQUAL (PARENT (X), AGGR (C1, TRUE)) THEN + FAILED ("INCORRECT CONVERSION TO PARENT"); + END IF; + + IF NOT EQUAL (X.C, C1) OR X.B /= TRUE THEN + FAILED ("INCORRECT SELECTION (VALUE)"); + END IF; + + X.B := IDENT_BOOL (FALSE); + IF NOT EQUAL (X, AGGR (C1, FALSE)) THEN + FAILED ("INCORRECT SELECTION (ASSIGNMENT)"); + END IF; + + X.B := IDENT_BOOL (TRUE); + IF NOT (X IN T) THEN + FAILED ("INCORRECT ""IN"""); + END IF; + + IF X NOT IN T THEN + FAILED ("INCORRECT ""NOT IN"""); + END IF; + + B := FALSE; + A (X'ADDRESS); + IF NOT B THEN + FAILED ("INCORRECT 'ADDRESS"); + END IF; + + IF X.C'FIRST_BIT < 0 THEN + FAILED ("INCORRECT 'FIRST_BIT"); + END IF; + + IF X.C'LAST_BIT < 0 OR + X.C'LAST_BIT - X.C'FIRST_BIT + 1 /= X.C'SIZE THEN + FAILED ("INCORRECT 'LAST_BIT"); + END IF; + + IF X.C'POSITION < 0 THEN + FAILED ("INCORRECT 'POSITION"); + END IF; + + IF X'SIZE < T'SIZE OR + X.C'SIZE < COMPONENT'SIZE OR + X.B'SIZE < BOOLEAN'SIZE THEN + FAILED ("INCORRECT OBJECT'SIZE"); + END IF; + + RESULT; +END C34006G; diff --git a/gcc-4.9/gcc/testsuite/ada/acats/tests/c3/c34006j.ada b/gcc-4.9/gcc/testsuite/ada/acats/tests/c3/c34006j.ada new file mode 100644 index 000000000..597bf63c5 --- /dev/null +++ b/gcc-4.9/gcc/testsuite/ada/acats/tests/c3/c34006j.ada @@ -0,0 +1,311 @@ +-- C34006J.ADA + +-- Grant of Unlimited Rights +-- +-- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687, +-- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained +-- unlimited rights in the software and documentation contained herein. +-- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making +-- this public release, the Government intends to confer upon all +-- recipients unlimited rights equal to those held by the Government. +-- These rights include rights to use, duplicate, release or disclose the +-- released technical data and computer software in whole or in part, in +-- any manner and for any purpose whatsoever, and to have or permit others +-- to do so. +-- +-- DISCLAIMER +-- +-- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR +-- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED +-- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF 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 REQUIRED PREDEFINED OPERATIONS ARE DECLARED +-- (IMPLICITLY) FOR DERIVED RECORD TYPES WITH DISCRIMINANTS AND WITH +-- A LIMITED COMPONENT TYPE. + +-- HISTORY: +-- JRK 08/25/87 CREATED ORIGINAL TEST. +-- VCL 06/28/88 MODIFIED THE STATEMENTS INVOLVING THE 'SIZE +-- ATTRIBUTE TO REMOVE ANY ASSUMPTIONS ABOUT THE +-- SIZES. +-- PWN 11/30/94 REMOVED 'BASE USE ILLEGAL IN ADA 9X. + +WITH SYSTEM; USE SYSTEM; +WITH REPORT; USE REPORT; + +PROCEDURE C34006J IS + + PACKAGE PKG_L IS + + TYPE LP IS LIMITED PRIVATE; + + FUNCTION CREATE (X : INTEGER) RETURN LP; + + FUNCTION EQUAL (X, Y : LP) RETURN BOOLEAN; + + PROCEDURE ASSIGN (X : OUT LP; Y : LP); + + C4 : CONSTANT LP; + C5 : CONSTANT LP; + + PRIVATE + + TYPE LP IS NEW INTEGER; + + C4 : CONSTANT LP := 4; + C5 : CONSTANT LP := 5; + + END PKG_L; + + USE PKG_L; + + SUBTYPE COMPONENT IS LP; + + PACKAGE PKG_P IS + + MAX_LEN : CONSTANT := 10; + + SUBTYPE LENGTH IS NATURAL RANGE 0 .. MAX_LEN; + + TYPE PARENT (B : BOOLEAN := TRUE; L : LENGTH := 3) IS + RECORD + I : INTEGER := 2; + CASE B IS + WHEN TRUE => + S : STRING (1 .. L) := (1 .. L => 'A'); + C : COMPONENT; + WHEN FALSE => + F : FLOAT := 5.0; + END CASE; + END RECORD; + + FUNCTION CREATE ( B : BOOLEAN; + L : LENGTH; + I : INTEGER; + S : STRING; + C : COMPONENT; + F : FLOAT; + X : PARENT -- TO RESOLVE OVERLOADING. + ) RETURN PARENT; + + FUNCTION EQUAL (X, Y : PARENT) RETURN BOOLEAN; + + FUNCTION AGGR ( B : BOOLEAN; + L : LENGTH; + I : INTEGER; + S : STRING; + C : COMPONENT + ) RETURN PARENT; + + FUNCTION AGGR ( B : BOOLEAN; + L : LENGTH; + I : INTEGER; + F : FLOAT + ) RETURN PARENT; + + END PKG_P; + + USE PKG_P; + + TYPE T IS NEW PARENT (IDENT_BOOL (TRUE), IDENT_INT (3)); + + X : T; + W : PARENT; + B : BOOLEAN := FALSE; + + PROCEDURE A (X : ADDRESS) IS + BEGIN + B := IDENT_BOOL (TRUE); + END A; + + PACKAGE BODY PKG_L IS + + FUNCTION CREATE (X : INTEGER) RETURN LP IS + BEGIN + RETURN LP (IDENT_INT (X)); + END CREATE; + + FUNCTION EQUAL (X, Y : LP) RETURN BOOLEAN IS + BEGIN + RETURN X = Y; + END EQUAL; + + PROCEDURE ASSIGN (X : OUT LP; Y : LP) IS + BEGIN + X := Y; + END ASSIGN; + + END PKG_L; + + PACKAGE BODY PKG_P IS + + FUNCTION CREATE + ( B : BOOLEAN; + L : LENGTH; + I : INTEGER; + S : STRING; + C : COMPONENT; + F : FLOAT; + X : PARENT + ) RETURN PARENT + IS + A : PARENT (B, L); + BEGIN + A.I := I; + CASE B IS + WHEN TRUE => + A.S := S; + ASSIGN (A.C, C); + WHEN FALSE => + A.F := F; + END CASE; + RETURN A; + END CREATE; + + FUNCTION EQUAL (X, Y : PARENT) RETURN BOOLEAN IS + BEGIN + IF X.B /= Y.B OR X.L /= Y.L OR X.I /= Y.I THEN + RETURN FALSE; + END IF; + CASE X.B IS + WHEN TRUE => + RETURN X.S = Y.S AND EQUAL (X.C, Y.C); + WHEN FALSE => + RETURN X.F = Y.F; + END CASE; + END EQUAL; + + FUNCTION AGGR + ( B : BOOLEAN; + L : LENGTH; + I : INTEGER; + S : STRING; + C : COMPONENT + ) RETURN PARENT + IS + RESULT : PARENT (B, L); + BEGIN + RESULT.I := I; + RESULT.S := S; + ASSIGN (RESULT.C, C); + RETURN RESULT; + END AGGR; + + FUNCTION AGGR + ( B : BOOLEAN; + L : LENGTH; + I : INTEGER; + F : FLOAT + ) RETURN PARENT + IS + RESULT : PARENT (B, L); + BEGIN + RESULT.I := I; + RESULT.F := F; + RETURN RESULT; + END AGGR; + + END PKG_P; + +BEGIN + TEST ("C34006J", "CHECK THAT THE REQUIRED PREDEFINED OPERATIONS " & + "ARE DECLARED (IMPLICITLY) FOR DERIVED " & + "RECORD TYPES WITH DISCRIMINANTS AND WITH A " & + "LIMITED COMPONENT TYPE"); + + X.I := IDENT_INT (1); + X.S := IDENT_STR ("ABC"); + ASSIGN (X.C, CREATE (4)); + + W.I := IDENT_INT (1); + W.S := IDENT_STR ("ABC"); + ASSIGN (W.C, CREATE (4)); + + IF NOT EQUAL (T'(X), AGGR (TRUE, 3, 1, "ABC", C4)) THEN + FAILED ("INCORRECT QUALIFICATION"); + END IF; + + IF NOT EQUAL (T(X), AGGR (TRUE, 3, 1, "ABC", C4)) THEN + FAILED ("INCORRECT SELF CONVERSION"); + END IF; + + IF NOT EQUAL (T(W), AGGR (TRUE, 3, 1, "ABC", C4)) THEN + FAILED ("INCORRECT CONVERSION FROM PARENT"); + END IF; + + IF NOT EQUAL (PARENT(X), AGGR (TRUE, 3, 1, "ABC", C4)) OR + NOT EQUAL (PARENT(CREATE (FALSE, 2, 3, "XX", C5, 6.0, X)), + AGGR (FALSE, 2, 3, 6.0)) THEN + FAILED ("INCORRECT CONVERSION TO PARENT"); + END IF; + + IF X.B /= TRUE OR X.L /= 3 OR + CREATE (FALSE, 2, 3, "XX", C5, 6.0, X).B /= FALSE OR + CREATE (FALSE, 2, 3, "XX", C5, 6.0, X).L /= 2 THEN + FAILED ("INCORRECT SELECTION (DISCRIMINANT)"); + END IF; + + IF X.I /= 1 OR X.S /= "ABC" OR NOT EQUAL (X.C, C4) OR + CREATE (FALSE, 2, 3, "XX", C5, 6.0, X).I /= 3 OR + CREATE (FALSE, 2, 3, "XX", C5, 6.0, X).F /= 6.0 THEN + FAILED ("INCORRECT SELECTION (VALUE)"); + END IF; + + X.I := IDENT_INT (7); + X.S := IDENT_STR ("XYZ"); + IF NOT EQUAL (X, AGGR (TRUE, 3, 7, "XYZ", C4)) THEN + FAILED ("INCORRECT SELECTION (ASSIGNMENT)"); + END IF; + + X.I := IDENT_INT (1); + X.S := IDENT_STR ("ABC"); + IF NOT (X IN T) OR AGGR (FALSE, 2, 3, 6.0) IN T THEN + FAILED ("INCORRECT ""IN"""); + END IF; + + IF X NOT IN T OR NOT (AGGR (FALSE, 2, 3, 6.0) NOT IN T) THEN + FAILED ("INCORRECT ""NOT IN"""); + END IF; + + B := FALSE; + A (X'ADDRESS); + IF NOT B THEN + FAILED ("INCORRECT 'ADDRESS"); + END IF; + + IF NOT X'CONSTRAINED THEN + FAILED ("INCORRECT 'CONSTRAINED"); + END IF; + + IF X.C'FIRST_BIT < 0 THEN + FAILED ("INCORRECT 'FIRST_BIT"); + END IF; + + IF X.C'LAST_BIT < 0 OR + X.C'LAST_BIT - X.C'FIRST_BIT + 1 /= X.C'SIZE THEN + FAILED ("INCORRECT 'LAST_BIT"); + END IF; + + IF X.C'POSITION < 0 THEN + FAILED ("INCORRECT 'POSITION"); + END IF; + + IF X'SIZE < T'SIZE THEN + COMMENT ("X'SIZE < T'SIZE"); + ELSIF X'SIZE = T'SIZE THEN + COMMENT ("X'SIZE = T'SIZE"); + ELSE + COMMENT ("X'SIZE > T'SIZE"); + END IF; + + RESULT; +EXCEPTION + WHEN OTHERS => + FAILED ("UNEXPECTED EXCEPTION RAISED WHILE CHECKING BASIC " & + "OPERATIONS"); + RESULT; +END C34006J; diff --git a/gcc-4.9/gcc/testsuite/ada/acats/tests/c3/c34006l.ada b/gcc-4.9/gcc/testsuite/ada/acats/tests/c3/c34006l.ada new file mode 100644 index 000000000..65a21f934 --- /dev/null +++ b/gcc-4.9/gcc/testsuite/ada/acats/tests/c3/c34006l.ada @@ -0,0 +1,345 @@ +-- C34006L.ADA + +-- Grant of Unlimited Rights +-- +-- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687, +-- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained +-- unlimited rights in the software and documentation contained herein. +-- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making +-- this public release, the Government intends to confer upon all +-- recipients unlimited rights equal to those held by the Government. +-- These rights include rights to use, duplicate, release or disclose the +-- released technical data and computer software in whole or in part, in +-- any manner and for any purpose whatsoever, and to have or permit others +-- to do so. +-- +-- DISCLAIMER +-- +-- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR +-- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED +-- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE +-- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE +-- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A +-- PARTICULAR PURPOSE OF SAID MATERIAL. +--* +-- OBJECTIVE: +-- FOR DERIVED RECORD TYPES WITH DISCRIMINANTS AND WITH A LIMITED +-- COMPONENT TYPE: + +-- CHECK THAT ALL VALUES OF THE PARENT (BASE) TYPE ARE PRESENT +-- FOR THE DERIVED (BASE) TYPE WHEN THE DERIVED TYPE DEFINITION +-- IS CONSTRAINED. + +-- CHECK THAT ANY CONSTRAINT IMPOSED ON THE PARENT SUBTYPE IS +-- ALSO IMPOSED ON THE DERIVED SUBTYPE. + +-- HISTORY: +-- JRK 08/26/87 CREATED ORIGINAL TEST. + +WITH REPORT; USE REPORT; + +PROCEDURE C34006L IS + + PACKAGE PKG_L IS + + TYPE LP IS LIMITED PRIVATE; + + FUNCTION CREATE (X : INTEGER) RETURN LP; + + FUNCTION EQUAL (X, Y : LP) RETURN BOOLEAN; + + PROCEDURE ASSIGN (X : OUT LP; Y : LP); + + C2 : CONSTANT LP; + C4 : CONSTANT LP; + C5 : CONSTANT LP; + C6 : CONSTANT LP; + + PRIVATE + + TYPE LP IS NEW INTEGER; + + C2 : CONSTANT LP := 2; + C4 : CONSTANT LP := 4; + C5 : CONSTANT LP := 5; + C6 : CONSTANT LP := 6; + + END PKG_L; + + USE PKG_L; + + SUBTYPE COMPONENT IS LP; + + PACKAGE PKG_P IS + + MAX_LEN : CONSTANT := 10; + + SUBTYPE LENGTH IS NATURAL RANGE 0 .. MAX_LEN; + + TYPE PARENT (B : BOOLEAN := TRUE; L : LENGTH := 3) IS + RECORD + I : INTEGER := 2; + CASE B IS + WHEN TRUE => + S : STRING (1 .. L) := (1 .. L => 'A'); + C : COMPONENT; + WHEN FALSE => + F : FLOAT := 5.0; + END CASE; + END RECORD; + + FUNCTION CREATE ( B : BOOLEAN; + L : LENGTH; + I : INTEGER; + S : STRING; + C : COMPONENT; + F : FLOAT; + X : PARENT -- TO RESOLVE OVERLOADING. + ) RETURN PARENT; + + FUNCTION EQUAL (X, Y : PARENT) RETURN BOOLEAN; + + FUNCTION AGGR ( B : BOOLEAN; + L : LENGTH; + I : INTEGER; + S : STRING; + C : COMPONENT + ) RETURN PARENT; + + FUNCTION AGGR ( B : BOOLEAN; + L : LENGTH; + I : INTEGER; + F : FLOAT + ) RETURN PARENT; + + END PKG_P; + + USE PKG_P; + + TYPE T IS NEW PARENT (IDENT_BOOL (TRUE), IDENT_INT (3)); + + SUBTYPE SUBPARENT IS PARENT (TRUE, 3); + + TYPE S IS NEW SUBPARENT; + + X : T; + Y : S; + + PACKAGE BODY PKG_L IS + + FUNCTION CREATE (X : INTEGER) RETURN LP IS + BEGIN + RETURN LP (IDENT_INT (X)); + END CREATE; + + FUNCTION EQUAL (X, Y : LP) RETURN BOOLEAN IS + BEGIN + RETURN X = Y; + END EQUAL; + + PROCEDURE ASSIGN (X : OUT LP; Y : LP) IS + BEGIN + X := Y; + END ASSIGN; + + END PKG_L; + + PACKAGE BODY PKG_P IS + + FUNCTION CREATE + ( B : BOOLEAN; + L : LENGTH; + I : INTEGER; + S : STRING; + C : COMPONENT; + F : FLOAT; + X : PARENT + ) RETURN PARENT + IS + A : PARENT (B, L); + BEGIN + A.I := I; + CASE B IS + WHEN TRUE => + A.S := S; + ASSIGN (A.C, C); + WHEN FALSE => + A.F := F; + END CASE; + RETURN A; + END CREATE; + + FUNCTION EQUAL (X, Y : PARENT) RETURN BOOLEAN IS + BEGIN + IF X.B /= Y.B OR X.L /= Y.L OR X.I /= Y.I THEN + RETURN FALSE; + END IF; + CASE X.B IS + WHEN TRUE => + RETURN X.S = Y.S AND EQUAL (X.C, Y.C); + WHEN FALSE => + RETURN X.F = Y.F; + END CASE; + END EQUAL; + + FUNCTION AGGR + ( B : BOOLEAN; + L : LENGTH; + I : INTEGER; + S : STRING; + C : COMPONENT + ) RETURN PARENT + IS + RESULT : PARENT (B, L); + BEGIN + RESULT.I := I; + RESULT.S := S; + ASSIGN (RESULT.C, C); + RETURN RESULT; + END AGGR; + + FUNCTION AGGR + ( B : BOOLEAN; + L : LENGTH; + I : INTEGER; + F : FLOAT + ) RETURN PARENT + IS + RESULT : PARENT (B, L); + BEGIN + RESULT.I := I; + RESULT.F := F; + RETURN RESULT; + END AGGR; + + END PKG_P; + + PROCEDURE ASSIGN (X : IN OUT T; Y : T) IS + BEGIN + X.I := Y.I; + X.S := Y.S; + ASSIGN (X.C, Y.C); + END ASSIGN; + + PROCEDURE ASSIGN (X : IN OUT S; Y : S) IS + BEGIN + X.I := Y.I; + X.S := Y.S; + ASSIGN (X.C, Y.C); + END ASSIGN; + +BEGIN + TEST ("C34006L", "CHECK THAT ALL VALUES OF THE PARENT (BASE) " & + "TYPE ARE PRESENT FOR THE DERIVED (BASE) TYPE " & + "WHEN THE DERIVED TYPE DEFINITION IS " & + "CONSTRAINED. ALSO CHECK THAT ANY CONSTRAINT " & + "IMPOSED ON THE PARENT SUBTYPE IS ALSO IMPOSED " & + "ON THE DERIVED SUBTYPE. CHECK FOR DERIVED " & + "RECORD TYPES WITH DISCRIMINANTS AND WITH A " & + "LIMITED COMPONENT TYPE"); + + ASSIGN (X.C, CREATE (2)); + ASSIGN (Y.C, C2); + + -- CHECK THAT BASE TYPE VALUES NOT IN THE SUBTYPE ARE PRESENT. + + IF NOT EQUAL (CREATE (FALSE, 2, 3, "ZZ", C5, 6.0, X), + AGGR (FALSE, 2, 3, 6.0)) OR + NOT EQUAL (CREATE (FALSE, 2, 3, "ZZ", C5, 6.0, Y), + AGGR (FALSE, 2, 3, 6.0)) THEN + FAILED ("CAN'T CREATE BASE TYPE VALUES OUTSIDE THE SUBTYPE"); + END IF; + + IF CREATE (FALSE, 2, 3, "ZZ", C5, 6.0, X) IN T OR + CREATE (FALSE, 2, 3, "ZZ", C5, 6.0, Y) IN S THEN + FAILED ("INCORRECT ""IN"""); + END IF; + + -- CHECK THE DERIVED SUBTYPE CONSTRAINT. + + IF X.B /= TRUE OR X.L /= 3 OR + Y.B /= TRUE OR Y.L /= 3 THEN + FAILED ("INCORRECT SELECTION OF DISCRIMINANT VALUES"); + END IF; + + IF NOT X'CONSTRAINED OR NOT Y'CONSTRAINED THEN + FAILED ("INCORRECT 'CONSTRAINED"); + END IF; + + BEGIN + ASSIGN (X, AGGR (TRUE, 3, 1, "ABC", C4)); + ASSIGN (Y, AGGR (TRUE, 3, 1, "ABC", C4)); + IF NOT EQUAL (PARENT (X), PARENT (Y)) THEN -- USE X AND Y. + FAILED ("INCORRECT CONVERSION TO PARENT"); + END IF; + EXCEPTION + WHEN OTHERS => + FAILED ("EXCEPTION RAISED BY OK ASSIGN CALL"); + END; + + BEGIN + ASSIGN (X, AGGR (FALSE, 3, 2, 6.0)); + FAILED ("CONSTRAINT_ERROR NOT RAISED -- " & + "ASSIGN (X, AGGR (FALSE, 3, 2, 6.0))"); + IF EQUAL (X, AGGR (FALSE, 3, 2, 6.0)) THEN -- USE X. + COMMENT ("X ALTERED -- " & + "ASSIGN (X, AGGR (FALSE, 3, 2, 6.0))"); + END IF; + EXCEPTION + WHEN CONSTRAINT_ERROR => + NULL; + WHEN OTHERS => + FAILED ("WRONG EXCEPTION RAISED -- " & + "ASSIGN (X, AGGR (FALSE, 3, 2, 6.0))"); + END; + + BEGIN + ASSIGN (X, AGGR (TRUE, 4, 2, "ZZZZ", C6)); + FAILED ("CONSTRAINT_ERROR NOT RAISED -- " & + "ASSIGN (X, AGGR (TRUE, 4, 2, ""ZZZZ"", C6))"); + IF EQUAL (X, AGGR (TRUE, 4, 2, "ZZZZ", C6)) THEN -- USE X. + COMMENT ("X ALTERED -- " & + "ASSIGN (X, AGGR (TRUE, 4, 2, ""ZZZZ"", C6))"); + END IF; + EXCEPTION + WHEN CONSTRAINT_ERROR => + NULL; + WHEN OTHERS => + FAILED ("WRONG EXCEPTION RAISED -- " & + "ASSIGN (X, AGGR (TRUE, 4, 2, ""ZZZZ"", C6))"); + END; + + BEGIN + ASSIGN (Y, AGGR (FALSE, 3, 2, 6.0)); + FAILED ("CONSTRAINT_ERROR NOT RAISED -- " & + "ASSIGN (Y, AGGR (FALSE, 3, 2, 6.0))"); + IF EQUAL (Y, AGGR (FALSE, 3, 2, 6.0)) THEN -- USE Y. + COMMENT ("Y ALTERED -- " & + "ASSIGN (Y, AGGR (FALSE, 3, 2, 6.0))"); + END IF; + EXCEPTION + WHEN CONSTRAINT_ERROR => + NULL; + WHEN OTHERS => + FAILED ("WRONG EXCEPTION RAISED -- " & + "ASSIGN (Y, AGGR (FALSE, 3, 2, 6.0))"); + END; + + BEGIN + ASSIGN (Y, AGGR (TRUE, 4, 2, "ZZZZ", C6)); + FAILED ("CONSTRAINT_ERROR NOT RAISED -- " & + "ASSIGN (Y, AGGR (TRUE, 4, 2, ""ZZZZ"", C6))"); + IF EQUAL (Y, AGGR (TRUE, 4, 2, "ZZZZ", C6)) THEN -- USE Y. + COMMENT ("Y ALTERED -- " & + "ASSIGN (Y, AGGR (TRUE, 4, 2, ""ZZZZ"", C6))"); + END IF; + EXCEPTION + WHEN CONSTRAINT_ERROR => + NULL; + WHEN OTHERS => + FAILED ("WRONG EXCEPTION RAISED -- " & + "ASSIGN (Y, AGGR (TRUE, 4, 2, ""ZZZZ"", C6))"); + END; + + RESULT; +END C34006L; diff --git a/gcc-4.9/gcc/testsuite/ada/acats/tests/c3/c34007a.ada b/gcc-4.9/gcc/testsuite/ada/acats/tests/c3/c34007a.ada new file mode 100644 index 000000000..d75c8cc45 --- /dev/null +++ b/gcc-4.9/gcc/testsuite/ada/acats/tests/c3/c34007a.ada @@ -0,0 +1,181 @@ +-- C34007A.ADA + +-- Grant of Unlimited Rights +-- +-- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687, +-- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained +-- unlimited rights in the software and documentation contained herein. +-- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making +-- this public release, the Government intends to confer upon all +-- recipients unlimited rights equal to those held by the Government. +-- These rights include rights to use, duplicate, release or disclose the +-- released technical data and computer software in whole or in part, in +-- any manner and for any purpose whatsoever, and to have or permit others +-- to do so. +-- +-- DISCLAIMER +-- +-- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR +-- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED +-- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF 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 REQUIRED PREDEFINED OPERATIONS ARE DECLARED +-- (IMPLICITLY) FOR DERIVED ACCESS TYPES WHOSE DESIGNATED TYPE IS +-- NOT AN ARRAY TYPE, A TASK TYPE, A RECORD TYPE, OR A TYPE WITH +-- DISCRIMINANTS. + +-- HISTORY: +-- JRK 09/24/86 CREATED ORIGINAL TEST. +-- BCB 10/21/87 CHANGED HEADER TO STANDARD FORMAT. REVISED TEST SO +-- T'STORAGE_SIZE IS NOT REQUIRED TO BE > 1. +-- BCB 09/26/88 REMOVED COMPARISON INVOLVING OBJECT SIZE. +-- BCB 03/07/90 PUT CHECK FOR 'STORAGE_SIZE IN EXCEPTION HANDLER. +-- THS 09/18/90 REMOVED DECLARATION OF B, MADE THE BODY OF +-- PROCEDURE A NULL, AND DELETED ALL REFERENCES TO B. +-- PWN 01/31/95 REMOVED INCONSISTENCIES WITH ADA 9X. + +WITH SYSTEM; USE SYSTEM; +WITH REPORT; USE REPORT; + +PROCEDURE C34007A IS + + TYPE DESIGNATED IS RANGE -100 .. 100; + + SUBTYPE SUBDESIGNATED IS DESIGNATED RANGE + DESIGNATED'VAL (IDENT_INT (-50)) .. + DESIGNATED'VAL (IDENT_INT ( 50)); + + TYPE PARENT IS ACCESS SUBDESIGNATED RANGE + DESIGNATED'VAL (IDENT_INT (-30)) .. + DESIGNATED'VAL (IDENT_INT ( 30)); + + TYPE T IS NEW PARENT; + + X : T := NEW DESIGNATED'(-30); + K : INTEGER := X'SIZE; + Y : T := NEW DESIGNATED'( 30); + W : PARENT := NEW DESIGNATED'( 30); + + PROCEDURE A (X : ADDRESS) IS + BEGIN + NULL; + END A; + + FUNCTION IDENT (X : T) RETURN T IS + BEGIN + IF X = NULL OR ELSE + EQUAL (DESIGNATED'POS (X.ALL), DESIGNATED'POS (X.ALL)) THEN + RETURN X; -- ALWAYS EXECUTED. + END IF; + RETURN NEW DESIGNATED; + END IDENT; + +BEGIN + TEST ("C34007A", "CHECK THAT THE REQUIRED PREDEFINED OPERATIONS " & + "ARE DECLARED (IMPLICITLY) FOR DERIVED " & + "ACCESS TYPES WHOSE DESIGNATED TYPE IS NOT AN " & + "ARRAY TYPE, A TASK TYPE, A RECORD TYPE, OR A " & + "TYPE WITH DISCRIMINANTS"); + + IF Y = NULL OR ELSE Y.ALL /= 30 THEN + FAILED ("INCORRECT INITIALIZATION"); + END IF; + + X := IDENT (Y); + IF X /= Y THEN + FAILED ("INCORRECT :="); + END IF; + + IF T'(X) /= Y THEN + FAILED ("INCORRECT QUALIFICATION"); + END IF; + + IF T (X) /= Y THEN + FAILED ("INCORRECT SELF CONVERSION"); + END IF; + + IF EQUAL (3, 3) THEN + W := NEW DESIGNATED'(-30); + END IF; + X := T (W); + IF X = NULL OR ELSE X = Y OR ELSE X.ALL /= -30 THEN + FAILED ("INCORRECT CONVERSION FROM PARENT"); + END IF; + + X := IDENT (Y); + W := PARENT (X); + IF W = NULL OR ELSE W.ALL /= 30 OR ELSE T (W) /= Y THEN + FAILED ("INCORRECT CONVERSION TO PARENT"); + END IF; + + IF IDENT (NULL) /= NULL OR X = NULL THEN + FAILED ("INCORRECT NULL"); + END IF; + + X := IDENT (NEW DESIGNATED'(30)); + IF X = NULL OR ELSE X = Y OR ELSE X.ALL /= 30 THEN + FAILED ("INCORRECT ALLOCATOR"); + END IF; + + X := IDENT (Y); + IF X.ALL /= 30 THEN + FAILED ("INCORRECT .ALL (VALUE)"); + END IF; + + X.ALL := DESIGNATED'VAL (IDENT_INT (10)); + IF X /= Y OR Y.ALL /= 10 THEN + FAILED ("INCORRECT .ALL (ASSIGNMENT)"); + END IF; + + Y.ALL := 30; + X := IDENT (NULL); + BEGIN + IF X.ALL = 0 THEN + FAILED ("NO EXCEPTION FOR NULL.ALL - 1"); + ELSE FAILED ("NO EXCEPTION FOR NULL.ALL - 2"); + END IF; + EXCEPTION + WHEN CONSTRAINT_ERROR => + NULL; + WHEN OTHERS => + FAILED ("WRONG EXCEPTION FOR NULL.ALL"); + END; + + X := IDENT (Y); + IF X = NULL OR X = NEW DESIGNATED OR NOT (X = Y) THEN + FAILED ("INCORRECT ="); + END IF; + + IF X /= Y OR NOT (X /= NULL) THEN + FAILED ("INCORRECT /="); + END IF; + + IF NOT (X IN T) THEN + FAILED ("INCORRECT ""IN"""); + END IF; + + IF X NOT IN T THEN + FAILED ("INCORRECT ""NOT IN"""); + END IF; + + A (X'ADDRESS); + + BEGIN + IF T'STORAGE_SIZE /= PARENT'STORAGE_SIZE THEN + FAILED ("COLLECTION SIZE OF DERIVED TYPE IS NOT " & + "EQUAL OF COLLECTION SIZE OF PARENT TYPE"); + END IF; + EXCEPTION + WHEN PROGRAM_ERROR => + COMMENT ("PROGRAM_ERROR RAISED FOR " & + "UNDEFINED STORAGE_SIZE (AI-00608)"); + WHEN OTHERS => + FAILED ("UNEXPECTED EXCEPTION RAISED"); + END; + + RESULT; +END C34007A; diff --git a/gcc-4.9/gcc/testsuite/ada/acats/tests/c3/c34007d.ada b/gcc-4.9/gcc/testsuite/ada/acats/tests/c3/c34007d.ada new file mode 100644 index 000000000..9378a2bbc --- /dev/null +++ b/gcc-4.9/gcc/testsuite/ada/acats/tests/c3/c34007d.ada @@ -0,0 +1,266 @@ +-- C34007D.ADA + +-- Grant of Unlimited Rights +-- +-- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687, +-- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained +-- unlimited rights in the software and documentation contained herein. +-- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making +-- this public release, the Government intends to confer upon all +-- recipients unlimited rights equal to those held by the Government. +-- These rights include rights to use, duplicate, release or disclose the +-- released technical data and computer software in whole or in part, in +-- any manner and for any purpose whatsoever, and to have or permit others +-- to do so. +-- +-- DISCLAIMER +-- +-- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR +-- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED +-- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF 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 REQUIRED PREDEFINED OPERATIONS ARE DECLARED +-- (IMPLICITLY) FOR DERIVED ACCESS TYPES WHOSE DESIGNATED TYPE IS A +-- ONE-DIMENSIONAL ARRAY TYPE. THIS TEST IS PART 1 OF 2 TESTS +-- WHICH COVER THE OBJECTIVE. THE SECOND PART IS IN TEST C34007V. + +-- HISTORY: +-- JRK 09/25/86 CREATED ORIGINAL TEST. +-- BCB 10/21/87 CHANGED HEADER TO STANDARD FORMAT. REVISED TEST SO +-- T'STORAGE_SIZE IS NOT REQUIRED TO BE > 1. +-- BCB 09/26/88 REMOVED COMPARISON INVOLVING OBJECT SIZE. +-- BCB 04/12/90 SPLIT ORIGINAL TEST INTO C34007D.ADA AND +-- C34007V.ADA. PUT CHECK FOR 'STORAGE_SIZE IN +-- EXCEPTION HANDLER. +-- THS 09/18/90 REMOVED DECLARATION OF B, MADE THE BODY OF +-- PROCEDURE A NULL, AND DELETED ALL REFERENCES TO B. +-- PWN 01/31/95 REMOVED INCONSISTENCIES WITH ADA 9X. + +WITH SYSTEM; USE SYSTEM; +WITH REPORT; USE REPORT; + +PROCEDURE C34007D IS + + SUBTYPE COMPONENT IS INTEGER; + + TYPE DESIGNATED IS ARRAY (NATURAL RANGE <>) OF COMPONENT; + + SUBTYPE SUBDESIGNATED IS DESIGNATED (IDENT_INT (5) .. + IDENT_INT (7)); + + PACKAGE PKG IS + + TYPE PARENT IS ACCESS DESIGNATED; + + END PKG; + + USE PKG; + + TYPE T IS NEW PARENT (IDENT_INT (5) .. IDENT_INT (7)); + + X : T := NEW SUBDESIGNATED'(OTHERS => 2); + K : INTEGER := X'SIZE; + Y : T := NEW SUBDESIGNATED'(1, 2, 3); + W : PARENT := NEW SUBDESIGNATED'(OTHERS => 2); + C : COMPONENT := 1; + N : CONSTANT := 1; + + PROCEDURE A (X : ADDRESS) IS + BEGIN + NULL; + END A; + + FUNCTION V RETURN T IS + BEGIN + RETURN NEW SUBDESIGNATED'(OTHERS => C); + END V; + + FUNCTION IDENT (X : T) RETURN T IS + BEGIN + IF X = NULL OR ELSE + EQUAL (X'LENGTH, X'LENGTH) THEN + RETURN X; -- ALWAYS EXECUTED. + END IF; + RETURN NEW SUBDESIGNATED; + END IDENT; + +BEGIN + TEST ("C34007D", "CHECK THAT THE REQUIRED PREDEFINED OPERATIONS " & + "ARE DECLARED (IMPLICITLY) FOR DERIVED " & + "ACCESS TYPES WHOSE DESIGNATED TYPE IS A " & + "ONE-DIMENSIONAL ARRAY TYPE. THIS TEST IS " & + "PART 1 OF 2 TESTS WHICH COVER THE OBJECTIVE. " & + "THE SECOND PART IS IN TEST C34007V"); + + IF Y = NULL OR ELSE Y.ALL /= (1, 2, 3) THEN + FAILED ("INCORRECT INITIALIZATION"); + END IF; + + X := IDENT (Y); + IF X /= Y THEN + FAILED ("INCORRECT :="); + END IF; + + IF T'(X) /= Y THEN + FAILED ("INCORRECT QUALIFICATION"); + END IF; + + IF T (X) /= Y THEN + FAILED ("INCORRECT SELF CONVERSION"); + END IF; + + IF EQUAL (3, 3) THEN + W := NEW SUBDESIGNATED'(1, 2, 3); + END IF; + X := T (W); + IF X = NULL OR ELSE X = Y OR ELSE X.ALL /= (1, 2, 3) THEN + FAILED ("INCORRECT CONVERSION FROM PARENT"); + END IF; + + X := IDENT (Y); + W := PARENT (X); + IF W = NULL OR ELSE W.ALL /= (1, 2, 3) OR ELSE T (W) /= Y THEN + FAILED ("INCORRECT CONVERSION TO PARENT - 1"); + END IF; + + IF IDENT (NULL) /= NULL OR X = NULL THEN + FAILED ("INCORRECT NULL"); + END IF; + + X := IDENT (NEW SUBDESIGNATED'(1, 2, 3)); + IF (X = NULL OR ELSE X = Y OR ELSE X.ALL /= (1, 2, 3)) OR + X = NEW DESIGNATED'(1, 2) THEN + FAILED ("INCORRECT ALLOCATOR"); + END IF; + + X := IDENT (NULL); + BEGIN + IF X.ALL = (0, 0, 0) THEN + FAILED ("NO EXCEPTION FOR NULL.ALL - 1"); + ELSE FAILED ("NO EXCEPTION FOR NULL.ALL - 2"); + END IF; + EXCEPTION + WHEN CONSTRAINT_ERROR => + NULL; + WHEN OTHERS => + FAILED ("WRONG EXCEPTION FOR NULL.ALL"); + END; + + X := IDENT (Y); + X (IDENT_INT (7)) := 4; + IF X /= Y OR Y.ALL /= (1, 2, 4) THEN + FAILED ("INCORRECT INDEX (ASSIGNMENT)"); + END IF; + + Y.ALL := (1, 2, 3); + X := IDENT (Y); + X (IDENT_INT (5) .. IDENT_INT (6)) := (4, 5); + IF X /= Y OR Y.ALL /= (4, 5, 3) THEN + FAILED ("INCORRECT SLICE (ASSIGNMENT)"); + END IF; + + A (X'ADDRESS); + + IF X'FIRST /= 5 THEN + FAILED ("INCORRECT OBJECT'FIRST"); + END IF; + + IF V'FIRST /= 5 THEN + FAILED ("INCORRECT VALUE'FIRST"); + END IF; + + IF X'FIRST (N) /= 5 THEN + FAILED ("INCORRECT OBJECT'FIRST (N)"); + END IF; + + IF V'FIRST (N) /= 5 THEN + FAILED ("INCORRECT VALUE'FIRST (N)"); + END IF; + + IF X'LAST /= 7 THEN + FAILED ("INCORRECT OBJECT'LAST"); + END IF; + + IF V'LAST /= 7 THEN + FAILED ("INCORRECT VALUE'LAST"); + END IF; + + IF X'LAST (N) /= 7 THEN + FAILED ("INCORRECT OBJECT'LAST (N)"); + END IF; + + IF V'LAST (N) /= 7 THEN + FAILED ("INCORRECT VALUE'LAST (N)"); + END IF; + + IF X'LENGTH /= 3 THEN + FAILED ("INCORRECT OBJECT'LENGTH"); + END IF; + + IF V'LENGTH /= 3 THEN + FAILED ("INCORRECT VALUE'LENGTH"); + END IF; + + IF X'LENGTH (N) /= 3 THEN + FAILED ("INCORRECT OBJECT'LENGTH (N)"); + END IF; + + IF V'LENGTH (N) /= 3 THEN + FAILED ("INCORRECT VALUE'LENGTH (N)"); + END IF; + + DECLARE + Y : DESIGNATED (X'RANGE); + BEGIN + IF Y'FIRST /= 5 OR Y'LAST /= 7 THEN + FAILED ("INCORRECT OBJECT'RANGE"); + END IF; + END; + + DECLARE + Y : DESIGNATED (V'RANGE); + BEGIN + IF Y'FIRST /= 5 OR Y'LAST /= 7 THEN + FAILED ("INCORRECT VALUE'RANGE"); + END IF; + END; + + DECLARE + Y : DESIGNATED (X'RANGE (N)); + BEGIN + IF Y'FIRST /= 5 OR Y'LAST /= 7 THEN + FAILED ("INCORRECT OBJECT'RANGE (N)"); + END IF; + END; + + DECLARE + Y : DESIGNATED (V'RANGE (N)); + BEGIN + IF Y'FIRST /= 5 OR Y'LAST /= 7 THEN + FAILED ("INCORRECT VALUE'RANGE (N)"); + END IF; + END; + + IF T'SIZE < 1 THEN + FAILED ("INCORRECT TYPE'SIZE"); + END IF; + + BEGIN + IF T'STORAGE_SIZE /= PARENT'STORAGE_SIZE THEN + FAILED ("COLLECTION SIZE OF DERIVED TYPE IS NOT " & + "EQUAL TO COLLECTION SIZE OF PARENT TYPE"); + END IF; + EXCEPTION + WHEN PROGRAM_ERROR => + COMMENT ("PROGRAM_ERROR RAISED FOR " & + "UNDEFINED STORAGE_SIZE (AI-00608)"); + WHEN OTHERS => + FAILED ("UNEXPECTED EXCEPTION RAISED"); + END; + + RESULT; +END C34007D; diff --git a/gcc-4.9/gcc/testsuite/ada/acats/tests/c3/c34007f.ada b/gcc-4.9/gcc/testsuite/ada/acats/tests/c3/c34007f.ada new file mode 100644 index 000000000..0e9222b58 --- /dev/null +++ b/gcc-4.9/gcc/testsuite/ada/acats/tests/c3/c34007f.ada @@ -0,0 +1,163 @@ +-- C34007F.ADA + +-- Grant of Unlimited Rights +-- +-- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687, +-- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained +-- unlimited rights in the software and documentation contained herein. +-- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making +-- this public release, the Government intends to confer upon all +-- recipients unlimited rights equal to those held by the Government. +-- These rights include rights to use, duplicate, release or disclose the +-- released technical data and computer software in whole or in part, in +-- any manner and for any purpose whatsoever, and to have or permit others +-- to do so. +-- +-- DISCLAIMER +-- +-- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR +-- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED +-- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE +-- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE +-- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A +-- PARTICULAR PURPOSE OF SAID MATERIAL. +--* +-- FOR DERIVED ACCESS TYPES WHOSE DESIGNATED TYPE IS A ONE-DIMENSIONAL +-- ARRAY TYPE: + +-- CHECK THAT ALL VALUES OF THE PARENT (BASE) TYPE ARE PRESENT FOR THE +-- DERIVED (BASE) TYPE WHEN THE DERIVED TYPE DEFINITION IS +-- CONSTRAINED. + +-- CHECK THAT ANY CONSTRAINT IMPOSED ON THE PARENT SUBTYPE IS ALSO +-- IMPOSED ON THE DERIVED SUBTYPE. + +-- JRK 9/25/86 + +WITH REPORT; USE REPORT; + +PROCEDURE C34007F IS + + SUBTYPE COMPONENT IS INTEGER; + + TYPE DESIGNATED IS ARRAY (NATURAL RANGE <>) OF COMPONENT; + + SUBTYPE SUBDESIGNATED IS DESIGNATED (5 .. 7); + + PACKAGE PKG IS + + TYPE PARENT IS ACCESS DESIGNATED; + + FUNCTION CREATE ( F, L : NATURAL; + C : COMPONENT; + DUMMY : PARENT -- TO RESOLVE OVERLOADING. + ) RETURN PARENT; + + END PKG; + + USE PKG; + + TYPE T IS NEW PARENT (IDENT_INT (5) .. IDENT_INT (7)); + + SUBTYPE SUBPARENT IS PARENT (5 .. 7); + + TYPE S IS NEW SUBPARENT; + + X : T := NEW SUBDESIGNATED'(OTHERS => 2); + Y : S := NEW SUBDESIGNATED'(OTHERS => 2); + + PACKAGE BODY PKG IS + + FUNCTION CREATE + ( F, L : NATURAL; + C : COMPONENT; + DUMMY : PARENT + ) RETURN PARENT + IS + A : PARENT := NEW DESIGNATED (F .. L); + B : COMPONENT := C; + BEGIN + FOR I IN F .. L LOOP + A (I) := B; + B := B + 1; + END LOOP; + RETURN A; + END CREATE; + + END PKG; + +BEGIN + TEST ("C34007F", "CHECK THAT ALL VALUES OF THE PARENT (BASE) " & + "TYPE ARE PRESENT FOR THE DERIVED (BASE) TYPE " & + "WHEN THE DERIVED TYPE DEFINITION IS " & + "CONSTRAINED. ALSO CHECK THAT ANY CONSTRAINT " & + "IMPOSED ON THE PARENT SUBTYPE IS ALSO IMPOSED " & + "ON THE DERIVED SUBTYPE. CHECK FOR DERIVED " & + "ACCESS TYPES WHOSE DESIGNATED TYPE IS A " & + "ONE-DIMENSIONAL ARRAY TYPE"); + + -- CHECK THAT BASE TYPE VALUES NOT IN THE SUBTYPE ARE PRESENT. + + IF CREATE (2, 3, 4, X) . ALL /= (4, 5) OR + CREATE (2, 3, 4, Y) . ALL /= (4, 5) THEN + FAILED ("CAN'T CREATE BASE TYPE VALUES OUTSIDE THE SUBTYPE"); + END IF; + + IF CREATE (2, 3, 4, X) IN T OR + CREATE (2, 3, 4, Y) IN S THEN + FAILED ("INCORRECT ""IN"""); + END IF; + + -- CHECK THE DERIVED SUBTYPE CONSTRAINT. + + IF X'FIRST /= 5 OR X'LAST /= 7 OR + Y'FIRST /= 5 OR Y'LAST /= 7 THEN + FAILED ("INCORRECT 'FIRST OR 'LAST"); + END IF; + + BEGIN + X := NEW SUBDESIGNATED'(1, 2, 3); + Y := NEW SUBDESIGNATED'(1, 2, 3); + IF PARENT (X) = PARENT (Y) OR -- USE X AND Y. + X.ALL /= Y.ALL THEN + FAILED ("INCORRECT ALLOCATOR OR CONVERSION TO PARENT"); + END IF; + EXCEPTION + WHEN OTHERS => + FAILED ("EXCEPTION RAISED BY OK ASSIGNMENT"); + END; + + BEGIN + X := NEW DESIGNATED'(6 .. 8 => 0); + FAILED ("CONSTRAINT_ERROR NOT RAISED -- " & + "X := NEW DESIGNATED'(6 .. 8 => 0)"); + IF X = NULL OR ELSE X.ALL = (0, 0, 0) THEN -- USE X. + COMMENT ("X ALTERED -- " & + "X := NEW DESIGNATED'(6 .. 8 => 0)"); + END IF; + EXCEPTION + WHEN CONSTRAINT_ERROR => + NULL; + WHEN OTHERS => + FAILED ("WRONG EXCEPTION RAISED -- " & + "X := NEW DESIGNATED'(6 .. 8 => 0)"); + END; + + BEGIN + Y := NEW DESIGNATED'(6 .. 8 => 0); + FAILED ("CONSTRAINT_ERROR NOT RAISED -- " & + "Y := NEW DESIGNATED'(6 .. 8 => 0)"); + IF Y = NULL OR ELSE Y.ALL = (0, 0, 0) THEN -- USE Y. + COMMENT ("Y ALTERED -- " & + "Y := NEW DESIGNATED'(6 .. 8 => 0)"); + END IF; + EXCEPTION + WHEN CONSTRAINT_ERROR => + NULL; + WHEN OTHERS => + FAILED ("WRONG EXCEPTION RAISED -- " & + "Y := NEW DESIGNATED'(6 .. 8 => 0)"); + END; + + RESULT; +END C34007F; diff --git a/gcc-4.9/gcc/testsuite/ada/acats/tests/c3/c34007g.ada b/gcc-4.9/gcc/testsuite/ada/acats/tests/c3/c34007g.ada new file mode 100644 index 000000000..85c0f2ab9 --- /dev/null +++ b/gcc-4.9/gcc/testsuite/ada/acats/tests/c3/c34007g.ada @@ -0,0 +1,350 @@ +-- C34007G.ADA + +-- Grant of Unlimited Rights +-- +-- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687, +-- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained +-- unlimited rights in the software and documentation contained herein. +-- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making +-- this public release, the Government intends to confer upon all +-- recipients unlimited rights equal to those held by the Government. +-- These rights include rights to use, duplicate, release or disclose the +-- released technical data and computer software in whole or in part, in +-- any manner and for any purpose whatsoever, and to have or permit others +-- to do so. +-- +-- DISCLAIMER +-- +-- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR +-- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED +-- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF 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 REQUIRED PREDEFINED OPERATIONS ARE DECLARED +-- (IMPLICITLY) FOR DERIVED ACCESS TYPES WHOSE DESIGNATED TYPE IS A +-- MULTI-DIMENSIONAL ARRAY TYPE. + +-- HISTORY: +-- JRK 09/25/86 CREATED ORIGINAL TEST. +-- BCB 10/21/87 CHANGED HEADER TO STANDARD FORMAT. REVISED TEST SO +-- T'STORAGE_SIZE IS NOT REQUIRED TO BE > 1. +-- BCB 03/07/90 PUT CHECK FOR 'STORAGE_SIZE IN EXCEPTION HANDLER. +-- THS 09/18/90 REMOVED DECLARATION OF B, MADE THE BODY OF +-- PROCEDURE A NULL, AND DELETED ALL REFERENCES TO B. +-- PWN 01/31/95 REMOVED INCONSISTENCIES WITH ADA 9X. + +WITH SYSTEM; USE SYSTEM; +WITH REPORT; USE REPORT; + +PROCEDURE C34007G IS + + SUBTYPE COMPONENT IS INTEGER; + + TYPE DESIGNATED IS ARRAY (NATURAL RANGE <>, NATURAL RANGE <>) OF + COMPONENT; + + SUBTYPE SUBDESIGNATED IS DESIGNATED + (IDENT_INT (4) .. IDENT_INT (5), + IDENT_INT (6) .. IDENT_INT (8)); + + PACKAGE PKG IS + + TYPE PARENT IS ACCESS DESIGNATED; + + FUNCTION CREATE ( F1, L1 : NATURAL; + F2, L2 : NATURAL; + C : COMPONENT; + DUMMY : PARENT -- TO RESOLVE OVERLOADING. + ) RETURN PARENT; + + END PKG; + + USE PKG; + + TYPE T IS NEW PARENT (IDENT_INT (4) .. IDENT_INT (5), + IDENT_INT (6) .. IDENT_INT (8)); + + X : T := NEW SUBDESIGNATED'(OTHERS => (OTHERS => 2)); + Y : T := NEW SUBDESIGNATED'((1, 2, 3), (4, 5, 6)); + W : PARENT := NEW SUBDESIGNATED'(OTHERS => (OTHERS => 2)); + C : COMPONENT := 1; + N : CONSTANT := 2; + + PROCEDURE A (X : ADDRESS) IS + BEGIN + NULL; + END A; + + FUNCTION V RETURN T IS + BEGIN + RETURN NEW SUBDESIGNATED'(OTHERS => (OTHERS => C)); + END V; + + PACKAGE BODY PKG IS + + FUNCTION CREATE + ( F1, L1 : NATURAL; + F2, L2 : NATURAL; + C : COMPONENT; + DUMMY : PARENT + ) RETURN PARENT + IS + A : PARENT := NEW DESIGNATED (F1 .. L1, F2 .. L2); + B : COMPONENT := C; + BEGIN + FOR I IN F1 .. L1 LOOP + FOR J IN F2 .. L2 LOOP + A (I, J) := B; + B := B + 1; + END LOOP; + END LOOP; + RETURN A; + END CREATE; + + END PKG; + + FUNCTION IDENT (X : T) RETURN T IS + BEGIN + IF X = NULL OR ELSE + EQUAL (X'LENGTH, X'LENGTH) THEN + RETURN X; -- ALWAYS EXECUTED. + END IF; + RETURN NEW SUBDESIGNATED; + END IDENT; + +BEGIN + TEST ("C34007G", "CHECK THAT THE REQUIRED PREDEFINED OPERATIONS " & + "ARE DECLARED (IMPLICITLY) FOR DERIVED " & + "ACCESS TYPES WHOSE DESIGNATED TYPE IS A " & + "MULTI-DIMENSIONAL ARRAY TYPE"); + + IF Y = NULL OR ELSE Y.ALL /= ((1, 2, 3), (4, 5, 6)) THEN + FAILED ("INCORRECT INITIALIZATION"); + END IF; + + X := IDENT (Y); + IF X /= Y THEN + FAILED ("INCORRECT :="); + END IF; + + IF T'(X) /= Y THEN + FAILED ("INCORRECT QUALIFICATION"); + END IF; + + IF T (X) /= Y THEN + FAILED ("INCORRECT SELF CONVERSION"); + END IF; + + IF EQUAL (3, 3) THEN + W := NEW SUBDESIGNATED'((1, 2, 3), (4, 5, 6)); + END IF; + X := T (W); + IF X = NULL OR ELSE X = Y OR ELSE + X.ALL /= ((1, 2, 3), (4, 5, 6)) THEN + FAILED ("INCORRECT CONVERSION FROM PARENT"); + END IF; + + X := IDENT (Y); + W := PARENT (X); + IF W = NULL OR ELSE W.ALL /= ((1, 2, 3), (4, 5, 6)) OR ELSE + T (W) /= Y THEN + FAILED ("INCORRECT CONVERSION TO PARENT - 1"); + END IF; + + W := PARENT (CREATE (6, 9, 2, 3, 4, X)); + IF W = NULL OR ELSE + W.ALL /= ((4, 5), (6, 7), (8, 9), (10, 11)) THEN + FAILED ("INCORRECT CONVERSION TO PARENT - 2"); + END IF; + + IF IDENT (NULL) /= NULL OR X = NULL THEN + FAILED ("INCORRECT NULL"); + END IF; + + X := IDENT (NEW SUBDESIGNATED'((1, 2, 3), (4, 5, 6))); + IF (X = NULL OR ELSE X = Y OR ELSE + X.ALL /= ((1, 2, 3), (4, 5, 6))) OR + X = NEW DESIGNATED'((1, 2), (3, 4), (5, 6)) THEN + FAILED ("INCORRECT ALLOCATOR"); + END IF; + + X := IDENT (Y); + IF X.ALL /= ((1, 2, 3), (4, 5, 6)) OR + CREATE (6, 9, 2, 3, 4, X) . ALL /= + ((4, 5), (6, 7), (8, 9), (10, 11)) THEN + FAILED ("INCORRECT .ALL (VALUE)"); + END IF; + + X.ALL := ((10, 11, 12), (13, 14, 15)); + IF X /= Y OR Y.ALL /= ((10, 11, 12), (13, 14, 15)) THEN + FAILED ("INCORRECT .ALL (ASSIGNMENT)"); + END IF; + + Y.ALL := ((1, 2, 3), (4, 5, 6)); + BEGIN + CREATE (6, 9, 2, 3, 4, X) . ALL := + ((20, 21), (22, 23), (24, 25), (26, 27)); + EXCEPTION + WHEN OTHERS => + FAILED ("EXCEPTION FOR .ALL (ASSIGNMENT)"); + END; + + X := IDENT (NULL); + BEGIN + IF X.ALL = ((0, 0, 0), (0, 0, 0)) THEN + FAILED ("NO EXCEPTION FOR NULL.ALL - 1"); + ELSE FAILED ("NO EXCEPTION FOR NULL.ALL - 2"); + END IF; + EXCEPTION + WHEN CONSTRAINT_ERROR => + NULL; + WHEN OTHERS => + FAILED ("WRONG EXCEPTION FOR NULL.ALL"); + END; + + X := IDENT (Y); + IF X (IDENT_INT (4), IDENT_INT (6)) /= 1 OR + CREATE (6, 9, 2, 3, 4, X) (9, 3) /= 11 THEN + FAILED ("INCORRECT INDEX (VALUE)"); + END IF; + + X (IDENT_INT (5), IDENT_INT (8)) := 7; + IF X /= Y OR Y.ALL /= ((1, 2, 3), (4, 5, 7)) THEN + FAILED ("INCORRECT INDEX (ASSIGNMENT)"); + END IF; + + Y.ALL := ((1, 2, 3), (4, 5, 6)); + X := IDENT (Y); + BEGIN + CREATE (6, 9, 2, 3, 4, X) (6, 2) := 15; + EXCEPTION + WHEN OTHERS => + FAILED ("EXCEPTION FOR INDEX (ASSIGNMENT)"); + END; + + IF X = NULL OR X = NEW SUBDESIGNATED OR NOT (X = Y) OR + X = CREATE (6, 9, 2, 3, 4, X) THEN + FAILED ("INCORRECT ="); + END IF; + + IF X /= Y OR NOT (X /= NULL) OR + NOT (X /= CREATE (7, 9, 2, 4, 1, X)) THEN + FAILED ("INCORRECT /="); + END IF; + + IF NOT (X IN T) OR CREATE (2, 3, 4, 5, 1, X) IN T THEN + FAILED ("INCORRECT ""IN"""); + END IF; + + IF X NOT IN T OR NOT (CREATE (7, 9, 2, 4, 1, X) NOT IN T) THEN + FAILED ("INCORRECT ""NOT IN"""); + END IF; + + A (X'ADDRESS); + + IF X'FIRST /= 4 THEN + FAILED ("INCORRECT OBJECT'FIRST"); + END IF; + + IF V'FIRST /= 4 THEN + FAILED ("INCORRECT VALUE'FIRST"); + END IF; + + IF X'FIRST (N) /= 6 THEN + FAILED ("INCORRECT OBJECT'FIRST (N)"); + END IF; + + IF V'FIRST (N) /= 6 THEN + FAILED ("INCORRECT VALUE'FIRST (N)"); + END IF; + + IF X'LAST /= 5 THEN + FAILED ("INCORRECT OBJECT'LAST"); + END IF; + + IF V'LAST /= 5 THEN + FAILED ("INCORRECT VALUE'LAST"); + END IF; + + IF X'LAST (N) /= 8 THEN + FAILED ("INCORRECT OBJECT'LAST (N)"); + END IF; + + IF V'LAST (N) /= 8 THEN + FAILED ("INCORRECT VALUE'LAST (N)"); + END IF; + + IF X'LENGTH /= 2 THEN + FAILED ("INCORRECT OBJECT'LENGTH"); + END IF; + + IF V'LENGTH /= 2 THEN + FAILED ("INCORRECT VALUE'LENGTH"); + END IF; + + IF X'LENGTH (N) /= 3 THEN + FAILED ("INCORRECT OBJECT'LENGTH (N)"); + END IF; + + IF V'LENGTH (N) /= 3 THEN + FAILED ("INCORRECT VALUE'LENGTH (N)"); + END IF; + + DECLARE + Y : DESIGNATED (X'RANGE, 1 .. 3); + BEGIN + IF Y'FIRST /= 4 OR Y'LAST /= 5 THEN + FAILED ("INCORRECT OBJECT'RANGE"); + END IF; + END; + + DECLARE + Y : DESIGNATED (V'RANGE, 1 .. 3); + BEGIN + IF Y'FIRST /= 4 OR Y'LAST /= 5 THEN + FAILED ("INCORRECT VALUE'RANGE"); + END IF; + END; + + DECLARE + Y : DESIGNATED (1 .. 2, X'RANGE (N)); + BEGIN + IF Y'FIRST (N) /= 6 OR Y'LAST (N) /= 8 THEN + FAILED ("INCORRECT OBJECT'RANGE (N)"); + END IF; + END; + + DECLARE + Y : DESIGNATED (1 .. 2, V'RANGE (N)); + BEGIN + IF Y'FIRST (N) /= 6 OR Y'LAST (N) /= 8 THEN + FAILED ("INCORRECT VALUE'RANGE (N)"); + END IF; + END; + + IF T'SIZE < 1 THEN + FAILED ("INCORRECT TYPE'SIZE"); + END IF; + + IF X'SIZE < T'SIZE THEN + FAILED ("INCORRECT OBJECT'SIZE"); + END IF; + + BEGIN + IF T'STORAGE_SIZE /= PARENT'STORAGE_SIZE THEN + FAILED ("COLLECTION SIZE OF DERIVED TYPE IS NOT " & + "EQUAL TO COLLECTION SIZE OF PARENT TYPE"); + END IF; + EXCEPTION + WHEN PROGRAM_ERROR => + COMMENT ("PROGRAM_ERROR RAISED FOR " & + "UNDEFINED STORAGE_SIZE (AI-00608)"); + WHEN OTHERS => + FAILED ("UNEXPECTED EXCEPTION RAISED"); + END; + + RESULT; +END C34007G; diff --git a/gcc-4.9/gcc/testsuite/ada/acats/tests/c3/c34007i.ada b/gcc-4.9/gcc/testsuite/ada/acats/tests/c3/c34007i.ada new file mode 100644 index 000000000..55bc2c494 --- /dev/null +++ b/gcc-4.9/gcc/testsuite/ada/acats/tests/c3/c34007i.ada @@ -0,0 +1,213 @@ +-- C34007I.ADA + +-- Grant of Unlimited Rights +-- +-- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687, +-- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained +-- unlimited rights in the software and documentation contained herein. +-- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making +-- this public release, the Government intends to confer upon all +-- recipients unlimited rights equal to those held by the Government. +-- These rights include rights to use, duplicate, release or disclose the +-- released technical data and computer software in whole or in part, in +-- any manner and for any purpose whatsoever, and to have or permit others +-- to do so. +-- +-- DISCLAIMER +-- +-- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR +-- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED +-- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE +-- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE +-- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A +-- PARTICULAR PURPOSE OF SAID MATERIAL. +--* +-- FOR DERIVED ACCESS TYPES WHOSE DESIGNATED TYPE IS A MULTI-DIMENSIONAL +-- ARRAY TYPE: + +-- CHECK THAT ALL VALUES OF THE PARENT (BASE) TYPE ARE PRESENT FOR THE +-- DERIVED (BASE) TYPE WHEN THE DERIVED TYPE DEFINITION IS +-- CONSTRAINED. + +-- CHECK THAT ANY CONSTRAINT IMPOSED ON THE PARENT SUBTYPE IS ALSO +-- IMPOSED ON THE DERIVED SUBTYPE. + +-- JRK 9/25/86 + +WITH REPORT; USE REPORT; + +PROCEDURE C34007I IS + + SUBTYPE COMPONENT IS INTEGER; + + TYPE DESIGNATED IS ARRAY (NATURAL RANGE <>, NATURAL RANGE <>) OF + COMPONENT; + + SUBTYPE SUBDESIGNATED IS DESIGNATED (4 .. 5, 6 .. 8); + + PACKAGE PKG IS + + TYPE PARENT IS ACCESS DESIGNATED; + + FUNCTION CREATE ( F1, L1 : NATURAL; + F2, L2 : NATURAL; + C : COMPONENT; + DUMMY : PARENT -- TO RESOLVE OVERLOADING. + ) RETURN PARENT; + + END PKG; + + USE PKG; + + TYPE T IS NEW PARENT (IDENT_INT (4) .. IDENT_INT (5), + IDENT_INT (6) .. IDENT_INT (8)); + + SUBTYPE SUBPARENT IS PARENT (4 .. 5, 6 .. 8); + + TYPE S IS NEW SUBPARENT; + + X : T := NEW SUBDESIGNATED'(OTHERS => (OTHERS => 2)); + Y : S := NEW SUBDESIGNATED'(OTHERS => (OTHERS => 2)); + + PACKAGE BODY PKG IS + + FUNCTION CREATE + ( F1, L1 : NATURAL; + F2, L2 : NATURAL; + C : COMPONENT; + DUMMY : PARENT + ) RETURN PARENT + IS + A : PARENT := NEW DESIGNATED (F1 .. L1, F2 .. L2); + B : COMPONENT := C; + BEGIN + FOR I IN F1 .. L1 LOOP + FOR J IN F2 .. L2 LOOP + A (I, J) := B; + B := B + 1; + END LOOP; + END LOOP; + RETURN A; + END CREATE; + + END PKG; + +BEGIN + TEST ("C34007I", "CHECK THAT ALL VALUES OF THE PARENT (BASE) " & + "TYPE ARE PRESENT FOR THE DERIVED (BASE) TYPE " & + "WHEN THE DERIVED TYPE DEFINITION IS " & + "CONSTRAINED. ALSO CHECK THAT ANY CONSTRAINT " & + "IMPOSED ON THE PARENT SUBTYPE IS ALSO IMPOSED " & + "ON THE DERIVED SUBTYPE. CHECK FOR DERIVED " & + "ACCESS TYPES WHOSE DESIGNATED TYPE IS A " & + "MULTI-DIMENSIONAL ARRAY TYPE"); + + -- CHECK THAT BASE TYPE VALUES NOT IN THE SUBTYPE ARE PRESENT. + + IF CREATE (6, 9, 2, 3, 1, X) . ALL /= + ((1, 2), (3, 4), (5, 6), (7, 8)) OR + CREATE (6, 9, 2, 3, 1, Y) . ALL /= + ((1, 2), (3, 4), (5, 6), (7, 8)) THEN + FAILED ("CAN'T CREATE BASE TYPE VALUES OUTSIDE THE SUBTYPE"); + END IF; + + IF CREATE (6, 9, 2, 3, 1, X) IN T OR + CREATE (6, 9, 2, 3, 1, Y) IN S THEN + FAILED ("INCORRECT ""IN"""); + END IF; + + -- CHECK THE DERIVED SUBTYPE CONSTRAINT. + + IF X'FIRST /= 4 OR X'LAST /= 5 OR + Y'FIRST /= 4 OR Y'LAST /= 5 OR + X'FIRST (2) /= 6 OR X'LAST (2) /= 8 OR + Y'FIRST (2) /= 6 OR Y'LAST (2) /= 8 THEN + FAILED ("INCORRECT 'FIRST OR 'LAST"); + END IF; + + BEGIN + X := NEW SUBDESIGNATED'((1, 2, 3), (4, 5, 6)); + Y := NEW SUBDESIGNATED'((1, 2, 3), (4, 5, 6)); + IF PARENT (X) = PARENT (Y) OR -- USE X AND Y. + X.ALL /= Y.ALL THEN + FAILED ("INCORRECT ALLOCATOR OR CONVERSION TO PARENT"); + END IF; + EXCEPTION + WHEN OTHERS => + FAILED ("EXCEPTION RAISED BY OK ASSIGNMENT"); + END; + + BEGIN + X := NEW DESIGNATED'(5 .. 6 => (6 .. 8 => 0)); + FAILED ("CONSTRAINT_ERROR NOT RAISED -- " & + "X := NEW DESIGNATED'(5 .. 6 => (6 .. 8 => 0))"); + IF X = NULL OR ELSE + X.ALL = ((0, 0, 0), (0, 0, 0)) THEN -- USE X. + COMMENT ("X ALTERED -- " & + "X := NEW DESIGNATED'(5 .. 6 => " & + "(6 .. 8 => 0))"); + END IF; + EXCEPTION + WHEN CONSTRAINT_ERROR => + NULL; + WHEN OTHERS => + FAILED ("WRONG EXCEPTION RAISED -- " & + "X := NEW DESIGNATED'(5 .. 6 => (6 .. 8 => 0))"); + END; + + BEGIN + X := NEW DESIGNATED'(4 .. 5 => (5 .. 7 => 0)); + FAILED ("CONSTRAINT_ERROR NOT RAISED -- " & + "X := NEW DESIGNATED'(4 .. 5 => (5 .. 7 => 0))"); + IF X = NULL OR ELSE + X.ALL = ((0, 0, 0), (0, 0, 0)) THEN -- USE X. + COMMENT ("X ALTERED -- " & + "X := NEW DESIGNATED'(4 .. 5 => " & + "(5 .. 7 => 0))"); + END IF; + EXCEPTION + WHEN CONSTRAINT_ERROR => + NULL; + WHEN OTHERS => + FAILED ("WRONG EXCEPTION RAISED -- " & + "X := NEW DESIGNATED'(4 .. 5 => (5 .. 7 => 0))"); + END; + + BEGIN + Y := NEW DESIGNATED'(5 .. 6 => (6 .. 8 => 0)); + FAILED ("CONSTRAINT_ERROR NOT RAISED -- " & + "Y := NEW DESIGNATED'(5 .. 6 => (6 .. 8 => 0))"); + IF Y = NULL OR ELSE + Y.ALL = ((0, 0, 0), (0, 0, 0)) THEN -- USE Y. + COMMENT ("Y ALTERED -- " & + "Y := NEW DESIGNATED'(5 .. 6 => " & + "(6 .. 8 => 0))"); + END IF; + EXCEPTION + WHEN CONSTRAINT_ERROR => + NULL; + WHEN OTHERS => + FAILED ("WRONG EXCEPTION RAISED -- " & + "Y := NEW DESIGNATED'(5 .. 6 => (6 .. 8 => 0))"); + END; + + BEGIN + Y := NEW DESIGNATED'(4 .. 5 => (5 .. 7 => 0)); + FAILED ("CONSTRAINT_ERROR NOT RAISED -- " & + "Y := NEW DESIGNATED'(4 .. 5 => (5 .. 7 => 0))"); + IF Y = NULL OR ELSE + Y.ALL = ((0, 0, 0), (0, 0, 0)) THEN -- USE Y. + COMMENT ("Y ALTERED -- " & + "Y := NEW DESIGNATED'(4 .. 5 => " & + "(5 .. 7 => 0))"); + END IF; + EXCEPTION + WHEN CONSTRAINT_ERROR => + NULL; + WHEN OTHERS => + FAILED ("WRONG EXCEPTION RAISED -- " & + "Y := NEW DESIGNATED'(4 .. 5 => (5 .. 7 => 0))"); + END; + + RESULT; +END C34007I; diff --git a/gcc-4.9/gcc/testsuite/ada/acats/tests/c3/c34007j.ada b/gcc-4.9/gcc/testsuite/ada/acats/tests/c3/c34007j.ada new file mode 100644 index 000000000..1ce054cb7 --- /dev/null +++ b/gcc-4.9/gcc/testsuite/ada/acats/tests/c3/c34007j.ada @@ -0,0 +1,258 @@ +-- C34007J.ADA + +-- Grant of Unlimited Rights +-- +-- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687, +-- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained +-- unlimited rights in the software and documentation contained herein. +-- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making +-- this public release, the Government intends to confer upon all +-- recipients unlimited rights equal to those held by the Government. +-- These rights include rights to use, duplicate, release or disclose the +-- released technical data and computer software in whole or in part, in +-- any manner and for any purpose whatsoever, and to have or permit others +-- to do so. +-- +-- DISCLAIMER +-- +-- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR +-- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED +-- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF 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 REQUIRED PREDEFINED OPERATIONS ARE DECLARED +-- (IMPLICITLY) FOR DERIVED ACCESS TYPES WHOSE DESIGNATED TYPE +-- IS A TASK TYPE. + +-- HISTORY: +-- JRK 09/26/86 CREATED ORIGINAL TEST. +-- JLH 09/25/87 REFORMATTED HEADER. +-- BCB 09/26/88 REMOVED COMPARISION INVOLVING OBJECT SIZE. +-- BCB 03/07/90 PUT CHECK FOR 'STORAGE_SIZE IN EXCEPTION HANDLER. +-- THS 09/18/90 REMOVED DECLARATION OF B, MADE THE BODY OF +-- PROCEDURE A NULL, AND DELETED ALL REFERENCES TO B. +-- PWN 01/31/95 REMOVED INCONSISTENCIES WITH ADA 9X. + +WITH SYSTEM; USE SYSTEM; +WITH REPORT; USE REPORT; + +PROCEDURE C34007J IS + + TASK TYPE DESIGNATED IS + ENTRY E (I : IN OUT INTEGER); + ENTRY F (1 .. 3) (I : INTEGER; J : OUT INTEGER); + ENTRY R (I : OUT INTEGER); + ENTRY W (I : INTEGER); + END DESIGNATED; + + TYPE PARENT IS ACCESS DESIGNATED; + + TYPE T IS NEW PARENT; + + X : T; + K : INTEGER := X'SIZE; + Y : T; + W : PARENT; + I : INTEGER := 0; + J : INTEGER := 0; + + PROCEDURE A (X : ADDRESS) IS + BEGIN + NULL; + END A; + + FUNCTION V RETURN T IS + BEGIN + RETURN NEW DESIGNATED; + END V; + + FUNCTION IDENT (X : T) RETURN T IS + BEGIN + IF (X = NULL OR ELSE X'CALLABLE) OR IDENT_BOOL (TRUE) THEN + RETURN X; -- ALWAYS EXECUTED. + END IF; + RETURN NEW DESIGNATED; + END IDENT; + + TASK BODY DESIGNATED IS + N : INTEGER := 1; + BEGIN + LOOP + SELECT + ACCEPT E (I : IN OUT INTEGER) DO + I := I + N; + END E; + OR + ACCEPT F (2) (I : INTEGER; J : OUT INTEGER) DO + J := I + N; + END F; + OR + ACCEPT R (I : OUT INTEGER) DO + I := N; + END R; + OR + ACCEPT W (I : INTEGER) DO + N := I; + END W; + OR + TERMINATE; + END SELECT; + END LOOP; + END DESIGNATED; + +BEGIN + TEST ("C34007J", "CHECK THAT THE REQUIRED PREDEFINED OPERATIONS " & + "ARE DECLARED (IMPLICITLY) FOR DERIVED " & + "ACCESS TYPES WHOSE DESIGNATED TYPE IS A " & + "TASK TYPE"); + + X := NEW DESIGNATED; + Y := NEW DESIGNATED; + W := NEW DESIGNATED; + + IF Y = NULL THEN + FAILED ("INCORRECT INITIALIZATION - 1"); + ELSE Y.W (2); + Y.R (I); + IF I /= 2 THEN + FAILED ("INCORRECT INITIALIZATION - 2"); + END IF; + END IF; + + X := IDENT (Y); + IF X /= Y THEN + FAILED ("INCORRECT :="); + END IF; + + IF T'(X) /= Y THEN + FAILED ("INCORRECT QUALIFICATION"); + END IF; + + IF T (X) /= Y THEN + FAILED ("INCORRECT SELF CONVERSION"); + END IF; + + IF EQUAL (3, 3) THEN + W := NEW DESIGNATED; + W.W (3); + END IF; + X := T (W); + IF X = NULL OR X = Y THEN + FAILED ("INCORRECT CONVERSION FROM PARENT - 1"); + ELSE I := 5; + X.E (I); + IF I /= 8 THEN + FAILED ("INCORRECT CONVERSION FROM PARENT - 2"); + END IF; + END IF; + + X := IDENT (Y); + W := PARENT (X); + IF W = NULL OR T (W) /= Y THEN + FAILED ("INCORRECT CONVERSION TO PARENT - 1"); + ELSE I := 5; + W.E (I); + IF I /= 7 THEN + FAILED ("INCORRECT CONVERSION TO PARENT - 2"); + END IF; + END IF; + + IF IDENT (NULL) /= NULL OR X = NULL THEN + FAILED ("INCORRECT NULL"); + END IF; + + X := IDENT (NEW DESIGNATED); + IF X = NULL OR X = Y THEN + FAILED ("INCORRECT ALLOCATOR - 1"); + ELSE I := 5; + X.E (I); + IF I /= 6 THEN + FAILED ("INCORRECT ALLOCATOR - 2"); + END IF; + END IF; + + X := IDENT (Y); + I := 5; + X.E (I); + IF I /= 7 THEN + FAILED ("INCORRECT SELECTION (ENTRY)"); + END IF; + + I := 5; + X.F (IDENT_INT (2)) (I, J); + IF J /= 7 THEN + FAILED ("INCORRECT SELECTION (FAMILY)"); + END IF; + + I := 5; + X.ALL.E (I); + IF I /= 7 THEN + FAILED ("INCORRECT .ALL"); + END IF; + + X := IDENT (NULL); + BEGIN + IF X.ALL'CALLABLE THEN + FAILED ("NO EXCEPTION FOR NULL.ALL - 1"); + ELSE FAILED ("NO EXCEPTION FOR NULL.ALL - 2"); + END IF; + EXCEPTION + WHEN CONSTRAINT_ERROR => + NULL; + WHEN OTHERS => + FAILED ("WRONG EXCEPTION FOR NULL.ALL"); + END; + + X := IDENT (Y); + IF X = NULL OR X = NEW DESIGNATED OR NOT (X = Y) THEN + FAILED ("INCORRECT ="); + END IF; + + IF X /= Y OR NOT (X /= NULL) THEN + FAILED ("INCORRECT /="); + END IF; + + IF NOT (X IN T) THEN + FAILED ("INCORRECT ""IN"""); + END IF; + + IF X NOT IN T THEN + FAILED ("INCORRECT ""NOT IN"""); + END IF; + + A (X'ADDRESS); + + IF NOT X'CALLABLE THEN + FAILED ("INCORRECT OBJECT'CALLABLE"); + END IF; + + IF NOT V'CALLABLE THEN + FAILED ("INCORRECT VALUE'CALLABLE"); + END IF; + + BEGIN + IF T'STORAGE_SIZE /= PARENT'STORAGE_SIZE THEN + FAILED ("COLLECTION SIZE OF DERIVED TYPE IS NOT " & + "EQUAL TO COLLECTION SIZE OF PARENT TYPE"); + END IF; + EXCEPTION + WHEN PROGRAM_ERROR => + COMMENT ("PROGRAM_ERROR RAISED FOR " & + "UNDEFINED STORAGE_SIZE (AI-00608)"); + WHEN OTHERS => + FAILED ("UNEXPECTED EXCEPTION RAISED"); + END; + + IF X'TERMINATED THEN + FAILED ("INCORRECT OBJECT'TERMINATED"); + END IF; + + IF V'TERMINATED THEN + FAILED ("INCORRECT VALUE'TERMINATED"); + END IF; + + RESULT; +END C34007J; diff --git a/gcc-4.9/gcc/testsuite/ada/acats/tests/c3/c34007m.ada b/gcc-4.9/gcc/testsuite/ada/acats/tests/c3/c34007m.ada new file mode 100644 index 000000000..e266f575c --- /dev/null +++ b/gcc-4.9/gcc/testsuite/ada/acats/tests/c3/c34007m.ada @@ -0,0 +1,191 @@ +-- C34007M.ADA + +-- Grant of Unlimited Rights +-- +-- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687, +-- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained +-- unlimited rights in the software and documentation contained herein. +-- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making +-- this public release, the Government intends to confer upon all +-- recipients unlimited rights equal to those held by the Government. +-- These rights include rights to use, duplicate, release or disclose the +-- released technical data and computer software in whole or in part, in +-- any manner and for any purpose whatsoever, and to have or permit others +-- to do so. +-- +-- DISCLAIMER +-- +-- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR +-- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED +-- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF 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 REQUIRED PREDEFINED OPERATIONS ARE DECLARED +-- (IMPLICITLY) FOR DERIVED ACCESS TYPES WHOSE DESIGNATED TYPE IS A +-- RECORD TYPE WITHOUT DISCRIMINANTS. + +-- HISTORY: +-- JRK 09/29/86 CREATED ORIGINAL TEST. +-- BCB 10/21/87 CHANGED HEADER TO STANDARD FORMAT. REVISED TEST SO +-- T'STORAGE_SIZE IS NOT REQUIRED TO BE > 1. +-- BCB 09/26/88 REMOVED COMPARISON INVOLVING OBJECT SIZE. +-- BCB 03/07/90 PUT CHECK FOR 'STORAGE_SIZE IN EXCEPTION HANDLER. +-- THS 09/18/90 REMOVED DECLARATION OF B, MADE THE BODY OF +-- PROCEDURE A NULL, AND DELETED ALL REFERENCES TO B. +-- PWN 01/31/95 REMOVED INCONSISTENCIES WITH ADA 9X. + +WITH SYSTEM; USE SYSTEM; +WITH REPORT; USE REPORT; + +PROCEDURE C34007M IS + + SUBTYPE COMPONENT IS INTEGER; + + TYPE DESIGNATED IS + RECORD + C : COMPONENT; + B : BOOLEAN := TRUE; + END RECORD; + + TYPE PARENT IS ACCESS DESIGNATED; + + TYPE T IS NEW PARENT; + + X : T := NEW DESIGNATED'(2, FALSE); + K : INTEGER := X'SIZE; + Y : T := NEW DESIGNATED'(1, TRUE); + W : PARENT := NEW DESIGNATED'(2, FALSE); + C : COMPONENT := 1; + + PROCEDURE A (X : ADDRESS) IS + BEGIN + NULL; + END A; + + FUNCTION IDENT (X : T) RETURN T IS + BEGIN + IF X = NULL OR ELSE EQUAL (X.C, X.C) THEN + RETURN X; -- ALWAYS EXECUTED. + END IF; + RETURN NEW DESIGNATED'(-1, FALSE); + END IDENT; + +BEGIN + TEST ("C34007M", "CHECK THAT THE REQUIRED PREDEFINED OPERATIONS " & + "ARE DECLARED (IMPLICITLY) FOR DERIVED " & + "ACCESS TYPES WHOSE DESIGNATED TYPE IS A " & + "RECORD TYPE WITHOUT DISCRIMINANTS"); + + IF Y = NULL OR ELSE Y.ALL /= (1, TRUE) THEN + FAILED ("INCORRECT INITIALIZATION"); + END IF; + + X := IDENT (Y); + IF X /= Y THEN + FAILED ("INCORRECT :="); + END IF; + + IF T'(X) /= Y THEN + FAILED ("INCORRECT QUALIFICATION"); + END IF; + + IF T (X) /= Y THEN + FAILED ("INCORRECT SELF CONVERSION"); + END IF; + + IF EQUAL (3, 3) THEN + W := NEW DESIGNATED'(1, TRUE); + END IF; + X := T (W); + IF X = NULL OR ELSE X = Y OR ELSE X.ALL /= (1, TRUE) THEN + FAILED ("INCORRECT CONVERSION FROM PARENT"); + END IF; + + X := IDENT (Y); + W := PARENT (X); + IF W = NULL OR ELSE W.ALL /= (1, TRUE) OR ELSE T (W) /= Y THEN + FAILED ("INCORRECT CONVERSION TO PARENT"); + END IF; + + IF IDENT (NULL) /= NULL OR X = NULL THEN + FAILED ("INCORRECT NULL"); + END IF; + + X := IDENT (NEW DESIGNATED'(1, TRUE)); + IF X = NULL OR ELSE X = Y OR ELSE X.ALL /= (1, TRUE) THEN + FAILED ("INCORRECT ALLOCATOR"); + END IF; + + X := IDENT (Y); + IF X.C /= 1 OR X.B /= TRUE THEN + FAILED ("INCORRECT SELECTION (VALUE)"); + END IF; + + X.C := IDENT_INT (3); + X.B := IDENT_BOOL (FALSE); + IF X /= Y OR Y.ALL /= (3, FALSE) THEN + FAILED ("INCORRECT SELECTION (ASSIGNMENT)"); + END IF; + + Y.ALL := (1, TRUE); + X := IDENT (Y); + IF X.ALL /= (1, TRUE) THEN + FAILED ("INCORRECT .ALL (VALUE)"); + END IF; + + X.ALL := (10, FALSE); + IF X /= Y OR Y.ALL /= (10, FALSE) THEN + FAILED ("INCORRECT .ALL (ASSIGNMENT)"); + END IF; + + Y.ALL := (1, TRUE); + X := IDENT (NULL); + BEGIN + IF X.ALL = (0, FALSE) THEN + FAILED ("NO EXCEPTION FOR NULL.ALL - 1"); + ELSE FAILED ("NO EXCEPTION FOR NULL.ALL - 2"); + END IF; + EXCEPTION + WHEN CONSTRAINT_ERROR => + NULL; + WHEN OTHERS => + FAILED ("WRONG EXCEPTION FOR NULL.ALL"); + END; + + X := IDENT (Y); + IF X = NULL OR X = NEW DESIGNATED OR NOT (X = Y) THEN + FAILED ("INCORRECT ="); + END IF; + + IF X /= Y OR NOT (X /= NULL) THEN + FAILED ("INCORRECT /="); + END IF; + + IF NOT (X IN T) THEN + FAILED ("INCORRECT ""IN"""); + END IF; + + IF X NOT IN T THEN + FAILED ("INCORRECT ""NOT IN"""); + END IF; + + A (X'ADDRESS); + + BEGIN + IF T'STORAGE_SIZE /= PARENT'STORAGE_SIZE THEN + FAILED ("COLLECTION SIZE OF DERIVED TYPE IS NOT " & + "EQUAL TO COLLECTION SIZE OF PARENT TYPE"); + END IF; + EXCEPTION + WHEN PROGRAM_ERROR => + COMMENT ("PROGRAM_ERROR RAISED FOR " & + "UNDEFINED STORAGE_SIZE (AI-00608)"); + WHEN OTHERS => + FAILED ("UNEXPECTED EXCEPTION RAISED"); + END; + + RESULT; +END C34007M; diff --git a/gcc-4.9/gcc/testsuite/ada/acats/tests/c3/c34007p.ada b/gcc-4.9/gcc/testsuite/ada/acats/tests/c3/c34007p.ada new file mode 100644 index 000000000..a6d85b0d6 --- /dev/null +++ b/gcc-4.9/gcc/testsuite/ada/acats/tests/c3/c34007p.ada @@ -0,0 +1,283 @@ +-- C34007P.ADA + +-- Grant of Unlimited Rights +-- +-- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687, +-- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained +-- unlimited rights in the software and documentation contained herein. +-- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making +-- this public release, the Government intends to confer upon all +-- recipients unlimited rights equal to those held by the Government. +-- These rights include rights to use, duplicate, release or disclose the +-- released technical data and computer software in whole or in part, in +-- any manner and for any purpose whatsoever, and to have or permit others +-- to do so. +-- +-- DISCLAIMER +-- +-- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR +-- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED +-- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF 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 REQUIRED PREDEFINED OPERATIONS ARE DECLARED +-- (IMPLICITLY) FOR DERIVED ACCESS TYPES WHOSE DESIGNATED TYPE IS A +-- RECORD TYPE WITH DISCRIMINANTS. + +-- HISTORY: +-- JRK 09/29/86 CREATED ORIGINAL TEST. +-- BCB 10/21/87 CHANGED HEADER TO STANDARD FORMAT. REVISED TEST SO +-- T'STORAGE_SIZE IS NOT REQUIRED TO BE > 1. +-- BCB 09/26/88 REMOVED COMPARISON INVOLVING OBJECT SIZE. +-- BCB 03/07/90 PUT CHECK FOR 'STORAGE_SIZE IN EXCEPTION HANDLER. +-- THS 09/18/90 REMOVED DECLARATION OF B, MADE THE BODY OF +-- PROCEDURE A NULL, AND DELETED ALL REFERENCES TO B. +-- PWN 01/31/95 REMOVED INCONSISTENCIES WITH ADA 9X. + +WITH SYSTEM; USE SYSTEM; +WITH REPORT; USE REPORT; + +PROCEDURE C34007P IS + + SUBTYPE COMPONENT IS INTEGER; + + SUBTYPE LENGTH IS NATURAL RANGE 0 .. 10; + + TYPE DESIGNATED (B : BOOLEAN := TRUE; L : LENGTH := 1) IS + RECORD + I : INTEGER; + CASE B IS + WHEN TRUE => + S : STRING (1 .. L); + C : COMPONENT; + WHEN FALSE => + F : FLOAT := 5.0; + END CASE; + END RECORD; + + SUBTYPE SUBDESIGNATED IS DESIGNATED (IDENT_BOOL (TRUE), + IDENT_INT (3)); + + PACKAGE PKG IS + + TYPE PARENT IS ACCESS DESIGNATED; + + FUNCTION CREATE ( B : BOOLEAN; + L : LENGTH; + I : INTEGER; + S : STRING; + C : COMPONENT; + F : FLOAT; + X : PARENT -- TO RESOLVE OVERLOADING. + ) RETURN PARENT; + + END PKG; + + USE PKG; + + TYPE T IS NEW PARENT (IDENT_BOOL (TRUE), IDENT_INT (3)); + + X : T := NEW DESIGNATED'(TRUE, 3, 2, "AAA", 2); + K : INTEGER := X'SIZE; + Y : T := NEW DESIGNATED'(TRUE, 3, 1, "ABC", 4); + W : PARENT := NEW DESIGNATED'(TRUE, 3, 2, "AAA", 2); + C : COMPONENT := 1; + + PROCEDURE A (X : ADDRESS) IS + BEGIN + NULL; + END A; + + PACKAGE BODY PKG IS + + FUNCTION CREATE + ( B : BOOLEAN; + L : LENGTH; + I : INTEGER; + S : STRING; + C : COMPONENT; + F : FLOAT; + X : PARENT + ) RETURN PARENT + IS + BEGIN + CASE B IS + WHEN TRUE => + RETURN NEW DESIGNATED'(TRUE, L, I, S, C); + WHEN FALSE => + RETURN NEW DESIGNATED'(FALSE, L, I, F); + END CASE; + END CREATE; + + END PKG; + + FUNCTION IDENT (X : T) RETURN T IS + BEGIN + IF X = NULL OR ELSE EQUAL (X.I, X.I) THEN + RETURN X; -- ALWAYS EXECUTED. + END IF; + RETURN NEW DESIGNATED'(TRUE, 3, -1, "---", -1); + END IDENT; + +BEGIN + TEST ("C34007P", "CHECK THAT THE REQUIRED PREDEFINED OPERATIONS " & + "ARE DECLARED (IMPLICITLY) FOR DERIVED " & + "ACCESS TYPES WHOSE DESIGNATED TYPE IS A " & + "RECORD TYPE WITH DISCRIMINANTS"); + + IF Y = NULL OR ELSE Y.ALL /= (TRUE, 3, 1, "ABC", 4) THEN + FAILED ("INCORRECT INITIALIZATION"); + END IF; + + X := IDENT (Y); + IF X /= Y THEN + FAILED ("INCORRECT :="); + END IF; + + IF T'(X) /= Y THEN + FAILED ("INCORRECT QUALIFICATION"); + END IF; + + IF T (X) /= Y THEN + FAILED ("INCORRECT SELF CONVERSION"); + END IF; + + IF EQUAL (3, 3) THEN + W := NEW DESIGNATED'(TRUE, 3, 1, "ABC", 4); + END IF; + X := T (W); + IF X = NULL OR ELSE X = Y OR ELSE + X.ALL /= (TRUE, 3, 1, "ABC", 4) THEN + FAILED ("INCORRECT CONVERSION FROM PARENT"); + END IF; + + X := IDENT (Y); + W := PARENT (X); + IF W = NULL OR ELSE W.ALL /= (TRUE, 3, 1, "ABC", 4) OR ELSE + T (W) /= Y THEN + FAILED ("INCORRECT CONVERSION TO PARENT - 1"); + END IF; + + W := PARENT (CREATE (FALSE, 2, 3, "XX", 5, 6.0, X)); + IF W = NULL OR ELSE W.ALL /= (FALSE, 2, 3, 6.0) THEN + FAILED ("INCORRECT CONVERSION TO PARENT - 2"); + END IF; + + IF IDENT (NULL) /= NULL OR X = NULL THEN + FAILED ("INCORRECT NULL"); + END IF; + + X := IDENT (NEW DESIGNATED'(TRUE, 3, 1, "ABC", 4)); + IF (X = NULL OR ELSE X = Y OR ELSE + X.ALL /= (TRUE, 3, 1, "ABC", 4)) OR + X = NEW DESIGNATED'(FALSE, 3, 1, 4.0) THEN + FAILED ("INCORRECT ALLOCATOR"); + END IF; + + X := IDENT (Y); + IF X.B /= TRUE OR X.L /= 3 OR + CREATE (FALSE, 2, 3, "XX", 5, 6.0, X) . B /= FALSE OR + CREATE (FALSE, 2, 3, "XX", 5, 6.0, X) . L /= 2 THEN + FAILED ("INCORRECT SELECTION (DISCRIMINANT)"); + END IF; + + IF X.I /= 1 OR X.S /= "ABC" OR X.C /= 4 OR + CREATE (FALSE, 2, 3, "XX", 5, 6.0, X) . I /= 3 OR + CREATE (FALSE, 2, 3, "XX", 5, 6.0, X) . F /= 6.0 THEN + FAILED ("INCORRECT SELECTION (VALUE)"); + END IF; + + X.I := IDENT_INT (7); + X.S := IDENT_STR ("XYZ"); + X.C := IDENT_INT (9); + IF X /= Y OR Y.ALL /= (TRUE, 3, 7, "XYZ", 9) THEN + FAILED ("INCORRECT SELECTION (ASSIGNMENT)"); + END IF; + + Y.ALL := (TRUE, 3, 1, "ABC", 4); + X := IDENT (Y); + BEGIN + CREATE (FALSE, 2, 3, "XX", 5, 6.0, X) . I := 10; + CREATE (FALSE, 2, 3, "XX", 5, 6.0, X) . F := 10.0; + EXCEPTION + WHEN OTHERS => + FAILED ("EXCEPTION FOR SELECTION (ASSIGNMENT)"); + END; + + IF X.ALL /= (TRUE, 3, 1, "ABC", 4) OR + CREATE (FALSE, 2, 3, "XX", 5, 6.0, X) . ALL /= + (FALSE, 2, 3, 6.0) THEN + FAILED ("INCORRECT .ALL (VALUE)"); + END IF; + + X.ALL := (TRUE, 3, 10, "ZZZ", 15); + IF X /= Y OR Y.ALL /= (TRUE, 3, 10, "ZZZ", 15) THEN + FAILED ("INCORRECT .ALL (ASSIGNMENT)"); + END IF; + + Y.ALL := (TRUE, 3, 1, "ABC", 4); + BEGIN + CREATE (FALSE, 2, 3, "XX", 5, 6.0, X) . ALL := + (FALSE, 2, 10, 15.0); + EXCEPTION + WHEN OTHERS => + FAILED ("EXCEPTION FOR .ALL (ASSIGNMENT)"); + END; + + X := IDENT (NULL); + BEGIN + IF X.ALL = (FALSE, 0, 0, 0.0) THEN + FAILED ("NO EXCEPTION FOR NULL.ALL - 1"); + ELSE FAILED ("NO EXCEPTION FOR NULL.ALL - 2"); + END IF; + EXCEPTION + WHEN CONSTRAINT_ERROR => + NULL; + WHEN OTHERS => + FAILED ("WRONG EXCEPTION FOR NULL.ALL"); + END; + + X := IDENT (Y); + IF X = NULL OR X = NEW SUBDESIGNATED OR NOT (X = Y) OR + X = CREATE (FALSE, 2, 3, "XX", 5, 6.0, X) THEN + FAILED ("INCORRECT ="); + END IF; + + IF X /= Y OR NOT (X /= NULL) OR + NOT (X /= CREATE (FALSE, 2, 3, "XX", 5, 6.0, X)) THEN + FAILED ("INCORRECT /="); + END IF; + + IF NOT (X IN T) OR CREATE (FALSE, 2, 3, "XX", 5, 6.0, X) IN T THEN + FAILED ("INCORRECT ""IN"""); + END IF; + + IF X NOT IN T OR + NOT (CREATE (FALSE, 2, 3, "XX", 5, 6.0, X) NOT IN T) THEN + FAILED ("INCORRECT ""NOT IN"""); + END IF; + + A (X'ADDRESS); + + IF T'SIZE < 1 THEN + FAILED ("INCORRECT TYPE'SIZE"); + END IF; + + BEGIN + IF T'STORAGE_SIZE /= PARENT'STORAGE_SIZE THEN + FAILED ("COLLECTION SIZE OF DERIVED TYPE IS NOT " & + "EQUAL TO COLLECTION SIZE OF PARENT TYPE"); + END IF; + EXCEPTION + WHEN PROGRAM_ERROR => + COMMENT ("PROGRAM_ERROR RAISED FOR " & + "UNDEFINED STORAGE_SIZE (AI-00608)"); + WHEN OTHERS => + FAILED ("UNEXPECTED EXCEPTION RAISED"); + END; + + RESULT; +END C34007P; diff --git a/gcc-4.9/gcc/testsuite/ada/acats/tests/c3/c34007r.ada b/gcc-4.9/gcc/testsuite/ada/acats/tests/c3/c34007r.ada new file mode 100644 index 000000000..096d84527 --- /dev/null +++ b/gcc-4.9/gcc/testsuite/ada/acats/tests/c3/c34007r.ada @@ -0,0 +1,218 @@ +-- C34007R.ADA + +-- Grant of Unlimited Rights +-- +-- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687, +-- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained +-- unlimited rights in the software and documentation contained herein. +-- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making +-- this public release, the Government intends to confer upon all +-- recipients unlimited rights equal to those held by the Government. +-- These rights include rights to use, duplicate, release or disclose the +-- released technical data and computer software in whole or in part, in +-- any manner and for any purpose whatsoever, and to have or permit others +-- to do so. +-- +-- DISCLAIMER +-- +-- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR +-- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED +-- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE +-- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE +-- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A +-- PARTICULAR PURPOSE OF SAID MATERIAL. +--* +-- FOR DERIVED ACCESS TYPES WHOSE DESIGNATED TYPE IS A RECORD TYPE +-- WITH DISCRIMINANTS: + +-- CHECK THAT ALL VALUES OF THE PARENT (BASE) TYPE ARE PRESENT FOR THE +-- DERIVED (BASE) TYPE WHEN THE DERIVED TYPE DEFINITION IS +-- CONSTRAINED. + +-- CHECK THAT ANY CONSTRAINT IMPOSED ON THE PARENT SUBTYPE IS ALSO +-- IMPOSED ON THE DERIVED SUBTYPE. + +-- JRK 9/29/86 + +WITH REPORT; USE REPORT; + +PROCEDURE C34007R IS + + SUBTYPE COMPONENT IS INTEGER; + + SUBTYPE LENGTH IS NATURAL RANGE 0 .. 10; + + TYPE DESIGNATED (B : BOOLEAN := TRUE; L : LENGTH := 1) IS + RECORD + I : INTEGER; + CASE B IS + WHEN TRUE => + S : STRING (1 .. L); + C : COMPONENT; + WHEN FALSE => + F : FLOAT := 5.0; + END CASE; + END RECORD; + + PACKAGE PKG IS + + TYPE PARENT IS ACCESS DESIGNATED; + + FUNCTION CREATE ( B : BOOLEAN; + L : LENGTH; + I : INTEGER; + S : STRING; + C : COMPONENT; + F : FLOAT; + X : PARENT -- TO RESOLVE OVERLOADING. + ) RETURN PARENT; + + END PKG; + + USE PKG; + + TYPE T IS NEW PARENT (IDENT_BOOL (TRUE), IDENT_INT (3)); + + SUBTYPE SUBPARENT IS PARENT (TRUE, 3); + + TYPE S IS NEW SUBPARENT; + + X : T := NEW DESIGNATED'(TRUE, 3, 2, "AAA", 2); + Y : S := NEW DESIGNATED'(TRUE, 3, 2, "AAA", 2); + + PACKAGE BODY PKG IS + + FUNCTION CREATE + ( B : BOOLEAN; + L : LENGTH; + I : INTEGER; + S : STRING; + C : COMPONENT; + F : FLOAT; + X : PARENT + ) RETURN PARENT + IS + BEGIN + CASE B IS + WHEN TRUE => + RETURN NEW DESIGNATED'(TRUE, L, I, S, C); + WHEN FALSE => + RETURN NEW DESIGNATED'(FALSE, L, I, F); + END CASE; + END CREATE; + + END PKG; + +BEGIN + TEST ("C34007R", "CHECK THAT ALL VALUES OF THE PARENT (BASE) " & + "TYPE ARE PRESENT FOR THE DERIVED (BASE) TYPE " & + "WHEN THE DERIVED TYPE DEFINITION IS " & + "CONSTRAINED. ALSO CHECK THAT ANY CONSTRAINT " & + "IMPOSED ON THE PARENT SUBTYPE IS ALSO IMPOSED " & + "ON THE DERIVED SUBTYPE. CHECK FOR DERIVED " & + "ACCESS TYPES WHOSE DESIGNATED TYPE IS A " & + "RECORD TYPE WITH DISCRIMINANTS"); + + -- CHECK THAT BASE TYPE VALUES NOT IN THE SUBTYPE ARE PRESENT. + + IF CREATE (FALSE, 2, 3, "ZZ", 5, 6.0, X) . ALL /= + (FALSE, 2, 3, 6.0) OR + CREATE (FALSE, 2, 3, "ZZ", 5, 6.0, Y) . ALL /= + (FALSE, 2, 3, 6.0) THEN + FAILED ("CAN'T CREATE BASE TYPE VALUES OUTSIDE THE SUBTYPE"); + END IF; + + IF CREATE (FALSE, 2, 3, "ZZ", 5, 6.0, X) IN T OR + CREATE (FALSE, 2, 3, "ZZ", 5, 6.0, Y) IN S THEN + FAILED ("INCORRECT ""IN"""); + END IF; + + -- CHECK THE DERIVED SUBTYPE CONSTRAINT. + + IF X.B /= TRUE OR X.L /= 3 OR + Y.B /= TRUE OR Y.L /= 3 THEN + FAILED ("INCORRECT SELECTION OF DISCRIMINANT VALUES"); + END IF; + + BEGIN + X := NEW DESIGNATED'(TRUE, 3, 1, "ABC", 4); + Y := NEW DESIGNATED'(TRUE, 3, 1, "ABC", 4); + IF PARENT (X) = PARENT (Y) OR -- USE X AND Y. + X.ALL /= Y.ALL THEN + FAILED ("INCORRECT ALLOCATOR OR CONVERSION TO PARENT"); + END IF; + EXCEPTION + WHEN OTHERS => + FAILED ("EXCEPTION RAISED BY OK ASSIGNMENT"); + END; + + BEGIN + X := NEW DESIGNATED'(FALSE, 3, 2, 6.0); + FAILED ("CONSTRAINT_ERROR NOT RAISED -- " & + "X := NEW DESIGNATED'(FALSE, 3, 2, 6.0)"); + IF X = NULL OR ELSE X.ALL = (FALSE, 3, 2, 6.0) THEN -- USE X. + COMMENT ("X ALTERED -- " & + "X := NEW DESIGNATED'(FALSE, 3, 2, 6.0)"); + END IF; + EXCEPTION + WHEN CONSTRAINT_ERROR => + NULL; + WHEN OTHERS => + FAILED ("WRONG EXCEPTION RAISED -- " & + "X := NEW DESIGNATED'(FALSE, 3, 2, 6.0)"); + END; + + BEGIN + X := NEW DESIGNATED'(TRUE, 4, 2, "ZZZZ", 6); + FAILED ("CONSTRAINT_ERROR NOT RAISED -- " & + "X := NEW DESIGNATED'(TRUE, 4, 2, ""ZZZZ"", 6)"); + IF X = NULL OR ELSE + X.ALL = (TRUE, 4, 2, "ZZZZ", 6) THEN -- USE X. + COMMENT ("X ALTERED -- " & + "X := NEW DESIGNATED'" & + "(TRUE, 4, 2, ""ZZZZ"", 6)"); + END IF; + EXCEPTION + WHEN CONSTRAINT_ERROR => + NULL; + WHEN OTHERS => + FAILED ("WRONG EXCEPTION RAISED -- " & + "X := NEW DESIGNATED'(TRUE, 4, 2, ""ZZZZ"", 6)"); + END; + + BEGIN + Y := NEW DESIGNATED'(FALSE, 3, 2, 6.0); + FAILED ("CONSTRAINT_ERROR NOT RAISED -- " & + "Y := NEW DESIGNATED'(FALSE, 3, 2, 6.0)"); + IF Y = NULL OR ELSE Y.ALL = (FALSE, 3, 2, 6.0) THEN -- USE Y. + COMMENT ("Y ALTERED -- " & + "Y := NEW DESIGNATED'(FALSE, 3, 2, 6.0)"); + END IF; + EXCEPTION + WHEN CONSTRAINT_ERROR => + NULL; + WHEN OTHERS => + FAILED ("WRONG EXCEPTION RAISED -- " & + "Y := NEW DESIGNATED'(FALSE, 3, 2, 6.0)"); + END; + + BEGIN + Y := NEW DESIGNATED'(TRUE, 4, 2, "ZZZZ", 6); + FAILED ("CONSTRAINT_ERROR NOT RAISED -- " & + "Y := NEW DESIGNATED'(TRUE, 4, 2, ""ZZZZ"", 6)"); + IF Y = NULL OR ELSE + Y.ALL = (TRUE, 4, 2, "ZZZZ", 6) THEN -- USE Y. + COMMENT ("Y ALTERED -- " & + "Y := NEW DESIGNATED'" & + "(TRUE, 4, 2, ""ZZZZ"", 6)"); + END IF; + EXCEPTION + WHEN CONSTRAINT_ERROR => + NULL; + WHEN OTHERS => + FAILED ("WRONG EXCEPTION RAISED -- " & + "Y := NEW DESIGNATED'(TRUE, 4, 2, ""ZZZZ"", 6)"); + END; + + RESULT; +END C34007R; diff --git a/gcc-4.9/gcc/testsuite/ada/acats/tests/c3/c34007s.ada b/gcc-4.9/gcc/testsuite/ada/acats/tests/c3/c34007s.ada new file mode 100644 index 000000000..54a2f3344 --- /dev/null +++ b/gcc-4.9/gcc/testsuite/ada/acats/tests/c3/c34007s.ada @@ -0,0 +1,299 @@ +-- C34007S.ADA + +-- Grant of Unlimited Rights +-- +-- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687, +-- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained +-- unlimited rights in the software and documentation contained herein. +-- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making +-- this public release, the Government intends to confer upon all +-- recipients unlimited rights equal to those held by the Government. +-- These rights include rights to use, duplicate, release or disclose the +-- released technical data and computer software in whole or in part, in +-- any manner and for any purpose whatsoever, and to have or permit others +-- to do so. +-- +-- DISCLAIMER +-- +-- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR +-- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED +-- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF 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 REQUIRED PREDEFINED OPERATIONS ARE DECLARED +-- (IMPLICITLY) FOR DERIVED ACCESS TYPES WHOSE DESIGNATED TYPE IS A +-- PRIVATE TYPE WITH DISCRIMINANTS. + +-- HISTORY: +-- JRK 09/30/86 CREATED ORIGINAL TEST. +-- BCB 10/21/87 CHANGED HEADER TO STANDARD FORMAT. REVISED TEST SO +-- T'STORAGE_SIZE IS NOT REQUIRED TO BE > 1. +-- BCB 09/26/88 REMOVED COMPARISON INVOLVING OBJECT SIZE. +-- BCB 03/07/90 PUT CHECK FOR 'STORAGE_SIZE IN EXCEPTION HANDLER. +-- THS 09/18/90 REMOVED DECLARATION OF B, MADE THE BODY OF +-- PROCEDURE A NULL, AND DELETED ALL REFERENCES TO B. +-- PWN 01/31/95 REMOVED INCONSISTENCIES WITH ADA 9X. + +WITH SYSTEM; USE SYSTEM; +WITH REPORT; USE REPORT; + +PROCEDURE C34007S IS + + SUBTYPE COMPONENT IS INTEGER; + + PACKAGE PKG_D IS + + SUBTYPE LENGTH IS NATURAL RANGE 0 .. 10; + + TYPE DESIGNATED (B : BOOLEAN := TRUE; L : LENGTH := 1) IS + PRIVATE; + + FUNCTION CREATE ( B : BOOLEAN; + L : LENGTH; + I : INTEGER; + S : STRING; + C : COMPONENT; + F : FLOAT + ) RETURN DESIGNATED; + + PRIVATE + + TYPE DESIGNATED (B : BOOLEAN := TRUE; L : LENGTH := 1) IS + RECORD + I : INTEGER := 2; + CASE B IS + WHEN TRUE => + S : STRING (1 .. L) := (1 .. L => 'A'); + C : COMPONENT := 2; + WHEN FALSE => + F : FLOAT := 5.0; + END CASE; + END RECORD; + + END PKG_D; + + USE PKG_D; + + SUBTYPE SUBDESIGNATED IS DESIGNATED (IDENT_BOOL (TRUE), + IDENT_INT (3)); + + PACKAGE PKG_P IS + + TYPE PARENT IS ACCESS DESIGNATED; + + FUNCTION CREATE ( B : BOOLEAN; + L : LENGTH; + I : INTEGER; + S : STRING; + C : COMPONENT; + F : FLOAT; + X : PARENT -- TO RESOLVE OVERLOADING. + ) RETURN PARENT; + + END PKG_P; + + USE PKG_P; + + TYPE T IS NEW PARENT (IDENT_BOOL (TRUE), IDENT_INT (3)); + + X : T := NEW DESIGNATED (TRUE, 3); + K : INTEGER := X'SIZE; + Y : T := NEW DESIGNATED (TRUE, 3); + W : PARENT := NEW DESIGNATED (TRUE, 3); + + PROCEDURE A (X : ADDRESS) IS + BEGIN + NULL; + END A; + + PACKAGE BODY PKG_D IS + + FUNCTION CREATE + ( B : BOOLEAN; + L : LENGTH; + I : INTEGER; + S : STRING; + C : COMPONENT; + F : FLOAT + ) RETURN DESIGNATED + IS + BEGIN + CASE B IS + WHEN TRUE => + RETURN (TRUE, L, I, S, C); + WHEN FALSE => + RETURN (FALSE, L, I, F); + END CASE; + END CREATE; + + END PKG_D; + + PACKAGE BODY PKG_P IS + + FUNCTION CREATE + ( B : BOOLEAN; + L : LENGTH; + I : INTEGER; + S : STRING; + C : COMPONENT; + F : FLOAT; + X : PARENT + ) RETURN PARENT + IS + BEGIN + RETURN NEW DESIGNATED'(CREATE (B, L, I, S, C, F)); + END CREATE; + + END PKG_P; + + FUNCTION IDENT (X : T) RETURN T IS + BEGIN + IF X = NULL OR ELSE EQUAL (X.L, X.L) THEN + RETURN X; -- ALWAYS EXECUTED. + END IF; + RETURN NEW DESIGNATED'(CREATE (TRUE, 3, -1, "---", -1, -1.0)); + END IDENT; + +BEGIN + TEST ("C34007S", "CHECK THAT THE REQUIRED PREDEFINED OPERATIONS " & + "ARE DECLARED (IMPLICITLY) FOR DERIVED " & + "ACCESS TYPES WHOSE DESIGNATED TYPE IS A " & + "PRIVATE TYPE WITH DISCRIMINANTS"); + + Y.ALL := CREATE (TRUE, 3, 1, "ABC", 4, 1.0); + IF Y = NULL OR ELSE + Y.ALL /= CREATE (TRUE, 3, 1, "ABC", 4, 2.0) THEN + FAILED ("INCORRECT INITIALIZATION"); + END IF; + + X := IDENT (Y); + IF X /= Y THEN + FAILED ("INCORRECT :="); + END IF; + + IF T'(X) /= Y THEN + FAILED ("INCORRECT QUALIFICATION"); + END IF; + + IF T (X) /= Y THEN + FAILED ("INCORRECT SELF CONVERSION"); + END IF; + + IF EQUAL (3, 3) THEN + W := NEW DESIGNATED'(CREATE (TRUE, 3, 1, "ABC", 4, 1.0)); + END IF; + X := T (W); + IF X = NULL OR ELSE X = Y OR ELSE + X.ALL /= CREATE (TRUE, 3, 1, "ABC", 4, 2.0) THEN + FAILED ("INCORRECT CONVERSION FROM PARENT"); + END IF; + + X := IDENT (Y); + W := PARENT (X); + IF W = NULL OR ELSE + W.ALL /= CREATE (TRUE, 3, 1, "ABC", 4, 2.0) OR ELSE + T (W) /= Y THEN + FAILED ("INCORRECT CONVERSION TO PARENT - 1"); + END IF; + + W := PARENT (CREATE (FALSE, 2, 3, "XX", 5, 6.0, X)); + IF W = NULL OR ELSE + W.ALL /= CREATE (FALSE, 2, 3, "ZZ", 7, 6.0) THEN + FAILED ("INCORRECT CONVERSION TO PARENT - 2"); + END IF; + + IF IDENT (NULL) /= NULL OR X = NULL THEN + FAILED ("INCORRECT NULL"); + END IF; + + X := IDENT (NEW DESIGNATED'(CREATE (TRUE, 3, 1, "ABC", 4, 1.0))); + IF (X = NULL OR ELSE X = Y OR ELSE + X.ALL /= CREATE (TRUE, 3, 1, "ABC", 4, 2.0)) OR + X = NEW DESIGNATED'(CREATE (FALSE, 3, 1, "XXX", 5, 4.0)) THEN + FAILED ("INCORRECT ALLOCATOR"); + END IF; + + X := IDENT (Y); + IF X.B /= TRUE OR X.L /= 3 OR + CREATE (FALSE, 2, 3, "XX", 5, 6.0, X) . B /= FALSE OR + CREATE (FALSE, 2, 3, "XX", 5, 6.0, X) . L /= 2 THEN + FAILED ("INCORRECT SELECTION (DISCRIMINANT)"); + END IF; + + IF X.ALL /= CREATE (TRUE, 3, 1, "ABC", 4, 2.0) OR + CREATE (FALSE, 2, 3, "XX", 5, 6.0, X) . ALL /= + CREATE (FALSE, 2, 3, "ZZ", 7, 6.0) THEN + FAILED ("INCORRECT .ALL (VALUE)"); + END IF; + + X.ALL := CREATE (TRUE, 3, 10, "ZZZ", 15, 1.0); + IF X /= Y OR Y.ALL /= CREATE (TRUE, 3, 10, "ZZZ", 15, 2.0) THEN + FAILED ("INCORRECT .ALL (ASSIGNMENT)"); + END IF; + + Y.ALL := CREATE (TRUE, 3, 1, "ABC", 4, 1.0); + BEGIN + CREATE (FALSE, 2, 3, "XX", 5, 6.0, X) . ALL := + CREATE (FALSE, 2, 10, "ZZ", 7, 15.0); + EXCEPTION + WHEN OTHERS => + FAILED ("EXCEPTION FOR .ALL (ASSIGNMENT)"); + END; + + X := IDENT (NULL); + BEGIN + IF X.ALL = CREATE (FALSE, 0, 0, "", 0, 0.0) THEN + FAILED ("NO EXCEPTION FOR NULL.ALL - 1"); + ELSE FAILED ("NO EXCEPTION FOR NULL.ALL - 2"); + END IF; + EXCEPTION + WHEN CONSTRAINT_ERROR => + NULL; + WHEN OTHERS => + FAILED ("WRONG EXCEPTION FOR NULL.ALL"); + END; + + X := IDENT (Y); + IF X = NULL OR X = NEW SUBDESIGNATED OR NOT (X = Y) OR + X = CREATE (FALSE, 2, 3, "XX", 5, 6.0, X) THEN + FAILED ("INCORRECT ="); + END IF; + + IF X /= Y OR NOT (X /= NULL) OR + NOT (X /= CREATE (FALSE, 2, 3, "XX", 5, 6.0, X)) THEN + FAILED ("INCORRECT /="); + END IF; + + IF NOT (X IN T) OR CREATE (FALSE, 2, 3, "XX", 5, 6.0, X) IN T THEN + FAILED ("INCORRECT ""IN"""); + END IF; + + IF X NOT IN T OR + NOT (CREATE (FALSE, 2, 3, "XX", 5, 6.0, X) NOT IN T) THEN + FAILED ("INCORRECT ""NOT IN"""); + END IF; + + A (X'ADDRESS); + + IF T'SIZE < 1 THEN + FAILED ("INCORRECT TYPE'SIZE"); + END IF; + + BEGIN + IF T'STORAGE_SIZE /= PARENT'STORAGE_SIZE THEN + FAILED ("COLLECTION SIZE OF DERIVED TYPE IS NOT " & + "EQUAL TO COLLECTION SIZE OF PARENT TYPE"); + END IF; + EXCEPTION + WHEN PROGRAM_ERROR => + COMMENT ("PROGRAM_ERROR RAISED FOR " & + "UNDEFINED STORAGE_SIZE (AI-00608)"); + WHEN OTHERS => + FAILED ("UNEXPECTED EXCEPTION RAISED"); + END; + + RESULT; +END C34007S; diff --git a/gcc-4.9/gcc/testsuite/ada/acats/tests/c3/c34007u.ada b/gcc-4.9/gcc/testsuite/ada/acats/tests/c3/c34007u.ada new file mode 100644 index 000000000..05c699025 --- /dev/null +++ b/gcc-4.9/gcc/testsuite/ada/acats/tests/c3/c34007u.ada @@ -0,0 +1,266 @@ +-- C34007U.ADA + +-- Grant of Unlimited Rights +-- +-- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687, +-- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained +-- unlimited rights in the software and documentation contained herein. +-- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making +-- this public release, the Government intends to confer upon all +-- recipients unlimited rights equal to those held by the Government. +-- These rights include rights to use, duplicate, release or disclose the +-- released technical data and computer software in whole or in part, in +-- any manner and for any purpose whatsoever, and to have or permit others +-- to do so. +-- +-- DISCLAIMER +-- +-- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR +-- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED +-- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE +-- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE +-- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A +-- PARTICULAR PURPOSE OF SAID MATERIAL. +--* +-- FOR DERIVED ACCESS TYPES WHOSE DESIGNATED TYPE IS A PRIVATE TYPE +-- WITH DISCRIMINANTS: + +-- CHECK THAT ALL VALUES OF THE PARENT (BASE) TYPE ARE PRESENT FOR THE +-- DERIVED (BASE) TYPE WHEN THE DERIVED TYPE DEFINITION IS +-- CONSTRAINED. + +-- CHECK THAT ANY CONSTRAINT IMPOSED ON THE PARENT SUBTYPE IS ALSO +-- IMPOSED ON THE DERIVED SUBTYPE. + +-- JRK 9/30/86 + +WITH REPORT; USE REPORT; + +PROCEDURE C34007U IS + + SUBTYPE COMPONENT IS INTEGER; + + PACKAGE PKG_D IS + + SUBTYPE LENGTH IS NATURAL RANGE 0 .. 10; + + TYPE DESIGNATED (B : BOOLEAN := TRUE; L : LENGTH := 1) IS + PRIVATE; + + FUNCTION CREATE ( B : BOOLEAN; + L : LENGTH; + I : INTEGER; + S : STRING; + C : COMPONENT; + F : FLOAT + ) RETURN DESIGNATED; + + PRIVATE + + TYPE DESIGNATED (B : BOOLEAN := TRUE; L : LENGTH := 1) IS + RECORD + I : INTEGER := 2; + CASE B IS + WHEN TRUE => + S : STRING (1 .. L) := (1 .. L => 'A'); + C : COMPONENT := 2; + WHEN FALSE => + F : FLOAT := 5.0; + END CASE; + END RECORD; + + END PKG_D; + + USE PKG_D; + + PACKAGE PKG_P IS + + TYPE PARENT IS ACCESS DESIGNATED; + + FUNCTION CREATE ( B : BOOLEAN; + L : LENGTH; + I : INTEGER; + S : STRING; + C : COMPONENT; + F : FLOAT; + X : PARENT -- TO RESOLVE OVERLOADING. + ) RETURN PARENT; + + END PKG_P; + + USE PKG_P; + + TYPE T IS NEW PARENT (IDENT_BOOL (TRUE), IDENT_INT (3)); + + SUBTYPE SUBPARENT IS PARENT (TRUE, 3); + + TYPE S IS NEW SUBPARENT; + + X : T := NEW DESIGNATED (TRUE, 3); + Y : S := NEW DESIGNATED (TRUE, 3); + + PACKAGE BODY PKG_D IS + + FUNCTION CREATE + ( B : BOOLEAN; + L : LENGTH; + I : INTEGER; + S : STRING; + C : COMPONENT; + F : FLOAT + ) RETURN DESIGNATED + IS + BEGIN + CASE B IS + WHEN TRUE => + RETURN (TRUE, L, I, S, C); + WHEN FALSE => + RETURN (FALSE, L, I, F); + END CASE; + END CREATE; + + END PKG_D; + + PACKAGE BODY PKG_P IS + + FUNCTION CREATE + ( B : BOOLEAN; + L : LENGTH; + I : INTEGER; + S : STRING; + C : COMPONENT; + F : FLOAT; + X : PARENT + ) RETURN PARENT + IS + BEGIN + RETURN NEW DESIGNATED'(CREATE (B, L, I, S, C, F)); + END CREATE; + + END PKG_P; + +BEGIN + TEST ("C34007U", "CHECK THAT ALL VALUES OF THE PARENT (BASE) " & + "TYPE ARE PRESENT FOR THE DERIVED (BASE) TYPE " & + "WHEN THE DERIVED TYPE DEFINITION IS " & + "CONSTRAINED. ALSO CHECK THAT ANY CONSTRAINT " & + "IMPOSED ON THE PARENT SUBTYPE IS ALSO IMPOSED " & + "ON THE DERIVED SUBTYPE. CHECK FOR DERIVED " & + "ACCESS TYPES WHOSE DESIGNATED TYPE IS A " & + "PRIVATE TYPE WITH DISCRIMINANTS"); + + -- CHECK THAT BASE TYPE VALUES NOT IN THE SUBTYPE ARE PRESENT. + + IF CREATE (FALSE, 2, 3, "WW", 5, 6.0, X) . ALL /= + CREATE (FALSE, 2, 3, "ZZ", 7, 6.0) OR + CREATE (FALSE, 2, 3, "WW", 5, 6.0, Y) . ALL /= + CREATE (FALSE, 2, 3, "ZZ", 7, 6.0) THEN + FAILED ("CAN'T CREATE BASE TYPE VALUES OUTSIDE THE SUBTYPE"); + END IF; + + IF CREATE (FALSE, 2, 3, "ZZ", 5, 6.0, X) IN T OR + CREATE (FALSE, 2, 3, "ZZ", 5, 6.0, Y) IN S THEN + FAILED ("INCORRECT ""IN"""); + END IF; + + -- CHECK THE DERIVED SUBTYPE CONSTRAINT. + + IF X.B /= TRUE OR X.L /= 3 OR + Y.B /= TRUE OR Y.L /= 3 THEN + FAILED ("INCORRECT SELECTION OF DISCRIMINANT VALUES"); + END IF; + + BEGIN + X := NEW DESIGNATED'(CREATE (TRUE, 3, 1, "ABC", 4, 1.0)); + Y := NEW DESIGNATED'(CREATE (TRUE, 3, 1, "ABC", 4, 1.0)); + IF PARENT (X) = PARENT (Y) OR -- USE X AND Y. + X.ALL /= Y.ALL THEN + FAILED ("INCORRECT ALLOCATOR OR CONVERSION TO PARENT"); + END IF; + EXCEPTION + WHEN OTHERS => + FAILED ("EXCEPTION RAISED BY OK ASSIGNMENT"); + END; + + BEGIN + X := NEW DESIGNATED'(CREATE (FALSE, 3, 2, "ZZZ", 5, 6.0)); + FAILED ("CONSTRAINT_ERROR NOT RAISED -- " & + "X := NEW DESIGNATED'" & + "(CREATE (FALSE, 3, 2, ""ZZZ"", 5, 6.0))"); + IF X = NULL OR ELSE + X.ALL = CREATE (FALSE, 3, 2, "ZZZ", 5, 6.0) THEN -- USE X. + COMMENT ("X ALTERED -- " & + "X := NEW DESIGNATED'" & + "(CREATE (FALSE, 3, 2, ""ZZZ"", 5, 6.0))"); + END IF; + EXCEPTION + WHEN CONSTRAINT_ERROR => + NULL; + WHEN OTHERS => + FAILED ("WRONG EXCEPTION RAISED -- " & + "X := NEW DESIGNATED'" & + "(CREATE (FALSE, 3, 2, ""ZZZ"", 5, 6.0))"); + END; + + BEGIN + X := NEW DESIGNATED'(CREATE (TRUE, 4, 2, "ZZZZ", 6, 7.0)); + FAILED ("CONSTRAINT_ERROR NOT RAISED -- " & + "X := NEW DESIGNATED'" & + "(CREATE (TRUE, 4, 2, ""ZZZZ"", 6, 7.0))"); + IF X = NULL OR ELSE + X.ALL = CREATE (TRUE, 4, 2, "ZZZZ", 6, 7.0) THEN -- USE X. + COMMENT ("X ALTERED -- " & + "X := NEW DESIGNATED'" & + "(CREATE (TRUE, 4, 2, ""ZZZZ"", 6, 7.0))"); + END IF; + EXCEPTION + WHEN CONSTRAINT_ERROR => + NULL; + WHEN OTHERS => + FAILED ("WRONG EXCEPTION RAISED -- " & + "X := NEW DESIGNATED'" & + "(CREATE (TRUE, 4, 2, ""ZZZZ"", 6, 7.0))"); + END; + + BEGIN + Y := NEW DESIGNATED'(CREATE (FALSE, 3, 2, "ZZZ", 5, 6.0)); + FAILED ("CONSTRAINT_ERROR NOT RAISED -- " & + "Y := NEW DESIGNATED'" & + "(CREATE (FALSE, 3, 2, ""ZZZ"", 5, 6.0))"); + IF Y = NULL OR ELSE + Y.ALL = CREATE (FALSE, 3, 2, "ZZZ", 5, 6.0) THEN -- USE Y. + COMMENT ("Y ALTERED -- " & + "Y := NEW DESIGNATED'" & + "(CREATE (FALSE, 3, 2, ""ZZZ"", 5, 6.0))"); + END IF; + EXCEPTION + WHEN CONSTRAINT_ERROR => + NULL; + WHEN OTHERS => + FAILED ("WRONG EXCEPTION RAISED -- " & + "Y := NEW DESIGNATED'" & + "(CREATE (FALSE, 3, 2, ""ZZZ"", 5, 6.0))"); + END; + + BEGIN + Y := NEW DESIGNATED'(CREATE (TRUE, 4, 2, "ZZZZ", 6, 7.0)); + FAILED ("CONSTRAINT_ERROR NOT RAISED -- " & + "Y := NEW DESIGNATED'" & + "(CREATE (TRUE, 4, 2, ""ZZZZ"", 6, 7.0))"); + IF Y = NULL OR ELSE + Y.ALL = CREATE (TRUE, 4, 2, "ZZZZ", 6, 7.0) THEN -- USE Y. + COMMENT ("Y ALTERED -- " & + "Y := NEW DESIGNATED'" & + "(CREATE (TRUE, 4, 2, ""ZZZZ"", 6, 7.0))"); + END IF; + EXCEPTION + WHEN CONSTRAINT_ERROR => + NULL; + WHEN OTHERS => + FAILED ("WRONG EXCEPTION RAISED -- " & + "Y := NEW DESIGNATED'" & + "(CREATE (TRUE, 4, 2, ""ZZZZ"", 6, 7.0))"); + END; + + RESULT; +END C34007U; diff --git a/gcc-4.9/gcc/testsuite/ada/acats/tests/c3/c34007v.ada b/gcc-4.9/gcc/testsuite/ada/acats/tests/c3/c34007v.ada new file mode 100644 index 000000000..8ee4bf829 --- /dev/null +++ b/gcc-4.9/gcc/testsuite/ada/acats/tests/c3/c34007v.ada @@ -0,0 +1,183 @@ +-- C34007V.ADA + +-- Grant of Unlimited Rights +-- +-- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687, +-- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained +-- unlimited rights in the software and documentation contained herein. +-- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making +-- this public release, the Government intends to confer upon all +-- recipients unlimited rights equal to those held by the Government. +-- These rights include rights to use, duplicate, release or disclose the +-- released technical data and computer software in whole or in part, in +-- any manner and for any purpose whatsoever, and to have or permit others +-- to do so. +-- +-- DISCLAIMER +-- +-- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR +-- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED +-- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF 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 REQUIRED PREDEFINED OPERATIONS ARE DECLARED +-- (IMPLICITLY) FOR DERIVED ACCESS TYPES WHOSE DESIGNATED TYPE IS A +-- ONE-DIMENSIONAL ARRAY TYPE. THIS TEST IS PART 2 OF 2 TESTS +-- WHICH COVER THE OBJECTIVE. THE FIRST PART IS IN TEST C34007D. + +-- HISTORY: +-- BCB 04/12/90 CREATED ORIGINAL TEST FROM SPLIT OF C34007D.ADA. +-- THS 09/18/90 REMOVED DECLARATION OF B, DELETED PROCEDURE A, +-- AND REMOVED ALL REFERENCES TO B. + +WITH SYSTEM; USE SYSTEM; +WITH REPORT; USE REPORT; + +PROCEDURE C34007V IS + + SUBTYPE COMPONENT IS INTEGER; + + TYPE DESIGNATED IS ARRAY (NATURAL RANGE <>) OF COMPONENT; + + SUBTYPE SUBDESIGNATED IS DESIGNATED (IDENT_INT (5) .. + IDENT_INT (7)); + + PACKAGE PKG IS + + TYPE PARENT IS ACCESS DESIGNATED; + + FUNCTION CREATE ( F, L : NATURAL; + C : COMPONENT; + DUMMY : PARENT -- TO RESOLVE OVERLOADING. + ) RETURN PARENT; + + END PKG; + + USE PKG; + + TYPE T IS NEW PARENT (IDENT_INT (5) .. IDENT_INT (7)); + + X : T := NEW SUBDESIGNATED'(OTHERS => 2); + K : INTEGER := X'SIZE; + Y : T := NEW SUBDESIGNATED'(1, 2, 3); + W : PARENT := NEW SUBDESIGNATED'(OTHERS => 2); + C : COMPONENT := 1; + N : CONSTANT := 1; + + FUNCTION V RETURN T IS + BEGIN + RETURN NEW SUBDESIGNATED'(OTHERS => C); + END V; + + PACKAGE BODY PKG IS + + FUNCTION CREATE + ( F, L : NATURAL; + C : COMPONENT; + DUMMY : PARENT + ) RETURN PARENT + IS + A : PARENT := NEW DESIGNATED (F .. L); + B : COMPONENT := C; + BEGIN + FOR I IN F .. L LOOP + A (I) := B; + B := B + 1; + END LOOP; + RETURN A; + END CREATE; + + END PKG; + + FUNCTION IDENT (X : T) RETURN T IS + BEGIN + IF X = NULL OR ELSE + EQUAL (X'LENGTH, X'LENGTH) THEN + RETURN X; -- ALWAYS EXECUTED. + END IF; + RETURN NEW SUBDESIGNATED; + END IDENT; + +BEGIN + TEST ("C34007V", "CHECK THAT THE REQUIRED PREDEFINED OPERATIONS " & + "ARE DECLARED (IMPLICITLY) FOR DERIVED " & + "ACCESS TYPES WHOSE DESIGNATED TYPE IS A " & + "ONE-DIMENSIONAL ARRAY TYPE. THIS TEST IS " & + "PART 2 OF 2 TESTS WHICH COVER THE OBJECTIVE. " & + "THE FIRST PART IS IN TEST C34007V"); + + W := PARENT (CREATE (2, 3, 4, X)); + IF W = NULL OR ELSE W.ALL /= (4, 5) THEN + FAILED ("INCORRECT CONVERSION TO PARENT - 2"); + END IF; + + X := IDENT (Y); + IF X.ALL /= (1, 2, 3) OR CREATE (2, 3, 4, X) . ALL /= (4, 5) THEN + FAILED ("INCORRECT .ALL (VALUE)"); + END IF; + + X.ALL := (10, 11, 12); + IF X /= Y OR Y.ALL /= (10, 11, 12) THEN + FAILED ("INCORRECT .ALL (ASSIGNMENT)"); + END IF; + + Y.ALL := (1, 2, 3); + BEGIN + CREATE (2, 3, 4, X) . ALL := (10, 11); + EXCEPTION + WHEN OTHERS => + FAILED ("EXCEPTION FOR .ALL (ASSIGNMENT)"); + END; + + + X := IDENT (Y); + IF X (IDENT_INT (5)) /= 1 OR + CREATE (2, 3, 4, X) (3) /= 5 THEN + FAILED ("INCORRECT INDEX (VALUE)"); + END IF; + + Y.ALL := (1, 2, 3); + X := IDENT (Y); + BEGIN + CREATE (2, 3, 4, X) (2) := 10; + EXCEPTION + WHEN OTHERS => + FAILED ("EXCEPTION FOR INDEX (ASSIGNMENT)"); + END; + + IF X (IDENT_INT (6) .. IDENT_INT (7)) /= (2, 3) OR + CREATE (1, 4, 4, X) (1 .. 3) /= (4, 5, 6) THEN + FAILED ("INCORRECT SLICE (VALUE)"); + END IF; + + Y.ALL := (1, 2, 3); + X := IDENT (Y); + BEGIN + CREATE (1, 4, 4, X) (2 .. 4) := (10, 11, 12); + EXCEPTION + WHEN OTHERS => + FAILED ("EXCEPTION FOR SLICE (ASSIGNMENT)"); + END; + + IF X = NULL OR X = NEW SUBDESIGNATED OR NOT (X = Y) OR + X = CREATE (2, 3, 4, X) THEN + FAILED ("INCORRECT ="); + END IF; + + IF X /= Y OR NOT (X /= NULL) OR NOT (X /= CREATE (2, 3, 4, X)) THEN + FAILED ("INCORRECT /="); + END IF; + + IF NOT (X IN T) OR CREATE (2, 3, 4, X) IN T THEN + FAILED ("INCORRECT ""IN"""); + END IF; + + IF X NOT IN T OR NOT (CREATE (2, 3, 4, X) NOT IN T) THEN + FAILED ("INCORRECT ""NOT IN"""); + END IF; + + RESULT; +END C34007V; diff --git a/gcc-4.9/gcc/testsuite/ada/acats/tests/c3/c34008a.ada b/gcc-4.9/gcc/testsuite/ada/acats/tests/c3/c34008a.ada new file mode 100644 index 000000000..5af4e3a56 --- /dev/null +++ b/gcc-4.9/gcc/testsuite/ada/acats/tests/c3/c34008a.ada @@ -0,0 +1,226 @@ +-- C34008A.ADA + +-- Grant of Unlimited Rights +-- +-- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687, +-- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained +-- unlimited rights in the software and documentation contained herein. +-- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making +-- this public release, the Government intends to confer upon all +-- recipients unlimited rights equal to those held by the Government. +-- These rights include rights to use, duplicate, release or disclose the +-- released technical data and computer software in whole or in part, in +-- any manner and for any purpose whatsoever, and to have or permit others +-- to do so. +-- +-- DISCLAIMER +-- +-- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR +-- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED +-- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF 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 REQUIRED PREDEFINED OPERATIONS ARE DECLARED +-- (IMPLICITLY) FOR DERIVED TASK TYPES. + +-- HISTORY: +-- JRK 08/27/87 CREATED ORIGINAL TEST. +-- PWN 11/30/94 REMOVED 'BASE USE ILLEGAL IN ADA 9X. +-- PWN 01/31/95 REMOVED INCONSISTENCIES WITH ADA 9X. +-- DTN 11/30/95 REMOVED ATTIBUTES OF NON-OBJECTS. + +WITH SYSTEM; USE SYSTEM; +WITH REPORT; USE REPORT; + +PROCEDURE C34008A IS + + PACKAGE PKG IS + + TASK TYPE PARENT IS + ENTRY E (I : IN OUT INTEGER); + ENTRY F (1 .. 3) (I : INTEGER; J : OUT INTEGER); + ENTRY G; + ENTRY H (1 .. 3); + ENTRY R (I : OUT INTEGER); + ENTRY W (I : INTEGER); + END PARENT; + + FUNCTION ID (X : PARENT) RETURN INTEGER; + + END PKG; + + USE PKG; + + TYPE T IS NEW PARENT; + + TASK TYPE AUX; + + X : T; + W : PARENT; + B : BOOLEAN := FALSE; + I : INTEGER := 0; + J : INTEGER := 0; + A1, A2 : AUX; + + PROCEDURE A (X : ADDRESS) IS + BEGIN + B := IDENT_BOOL (TRUE); + END A; + + FUNCTION V RETURN T IS + BEGIN + RETURN X; + END V; + + PACKAGE BODY PKG IS + + TASK BODY PARENT IS + N : INTEGER := 1; + BEGIN + LOOP + SELECT + ACCEPT E (I : IN OUT INTEGER) DO + I := I + N; + END E; + OR + ACCEPT F (2) (I : INTEGER; J : OUT INTEGER) DO + J := I + N; + END F; + OR + ACCEPT G DO + WHILE H(2)'COUNT < 2 LOOP + DELAY 5.0; + END LOOP; + ACCEPT H (2) DO + IF E'COUNT /= 0 OR + F(1)'COUNT /= 0 OR + F(2)'COUNT /= 0 OR + F(3)'COUNT /= 0 OR + G'COUNT /= 0 OR + H(1)'COUNT /= 0 OR + H(2)'COUNT /= 1 OR + H(3)'COUNT /= 0 OR + R'COUNT /= 0 OR + W'COUNT /= 0 THEN + FAILED ("INCORRECT 'COUNT"); + END IF; + END H; + ACCEPT H (2); + END G; + OR + ACCEPT R (I : OUT INTEGER) DO + I := N; + END R; + OR + ACCEPT W (I : INTEGER) DO + N := I; + END W; + OR + TERMINATE; + END SELECT; + END LOOP; + END PARENT; + + FUNCTION ID (X : PARENT) RETURN INTEGER IS + I : INTEGER; + BEGIN + X.R (I); + RETURN I; + END ID; + + END PKG; + + TASK BODY AUX IS + BEGIN + X.H (2); + END AUX; + +BEGIN + TEST ("C34008A", "CHECK THAT THE REQUIRED PREDEFINED OPERATIONS " & + "ARE DECLARED (IMPLICITLY) FOR DERIVED TASK " & + "TYPES"); + + X.W (IDENT_INT (2)); + IF ID (X) /= 2 THEN + FAILED ("INCORRECT INITIALIZATION"); + END IF; + + IF ID (T'(X)) /= 2 THEN + FAILED ("INCORRECT QUALIFICATION"); + END IF; + + IF ID (T (X)) /= 2 THEN + FAILED ("INCORRECT SELF CONVERSION"); + END IF; + + W.W (IDENT_INT (3)); + IF ID (T (W)) /= 3 THEN + FAILED ("INCORRECT CONVERSION FROM PARENT"); + END IF; + + IF ID (PARENT (X)) /= 2 THEN + FAILED ("INCORRECT CONVERSION TO PARENT"); + END IF; + + I := 5; + X.E (I); + IF I /= 7 THEN + FAILED ("INCORRECT SELECTION (ENTRY)"); + END IF; + + I := 5; + X.F (IDENT_INT (2)) (I, J); + IF J /= 7 THEN + FAILED ("INCORRECT SELECTION (FAMILY)"); + END IF; + + IF NOT (X IN T) THEN + FAILED ("INCORRECT ""IN"""); + END IF; + + IF X NOT IN T THEN + FAILED ("INCORRECT ""NOT IN"""); + END IF; + + + B := FALSE; + A (X'ADDRESS); + IF NOT B THEN + FAILED ("INCORRECT OBJECT'ADDRESS"); + END IF; + + IF NOT X'CALLABLE THEN + FAILED ("INCORRECT OBJECT'CALLABLE"); + END IF; + + IF NOT V'CALLABLE THEN + FAILED ("INCORRECT VALUE'CALLABLE"); + END IF; + + X.G; + + IF X'SIZE < T'SIZE THEN + FAILED ("INCORRECT OBJECT'SIZE"); + END IF; + + IF T'STORAGE_SIZE < 0 THEN + FAILED ("INCORRECT TYPE'STORAGE_SIZE"); + END IF; + + IF X'STORAGE_SIZE < 0 THEN + FAILED ("INCORRECT OBJECT'STORAGE_SIZE"); + END IF; + + IF X'TERMINATED THEN + FAILED ("INCORRECT OBJECT'TERMINATED"); + END IF; + + IF V'TERMINATED THEN + FAILED ("INCORRECT VALUE'TERMINATED"); + END IF; + + RESULT; +END C34008A; diff --git a/gcc-4.9/gcc/testsuite/ada/acats/tests/c3/c34009a.ada b/gcc-4.9/gcc/testsuite/ada/acats/tests/c3/c34009a.ada new file mode 100644 index 000000000..6cda3277f --- /dev/null +++ b/gcc-4.9/gcc/testsuite/ada/acats/tests/c3/c34009a.ada @@ -0,0 +1,134 @@ +-- C34009A.ADA + +-- Grant of Unlimited Rights +-- +-- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687, +-- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained +-- unlimited rights in the software and documentation contained herein. +-- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making +-- this public release, the Government intends to confer upon all +-- recipients unlimited rights equal to those held by the Government. +-- These rights include rights to use, duplicate, release or disclose the +-- released technical data and computer software in whole or in part, in +-- any manner and for any purpose whatsoever, and to have or permit others +-- to do so. +-- +-- DISCLAIMER +-- +-- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR +-- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED +-- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF 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 REQUIRED PREDEFINED OPERATIONS ARE DECLARED +-- (IMPLICITLY) FOR DERIVED NON-LIMITED PRIVATE TYPES WITHOUT +-- DISCRIMINANTS. + +-- HISTORY: +-- JRK 08/28/87 CREATED ORIGINAL TEST. +-- BCB 09/26/88 REMOVED COMPARISON INVOLVING OBJECT SIZE. +-- PWN 11/30/94 REMOVED 'BASE USE ILLEGAL IN ADA 9X. +-- PWN 01/31/95 REMOVED INCONSISTENCIES WITH ADA 9X. + +WITH SYSTEM; USE SYSTEM; +WITH REPORT; USE REPORT; + +PROCEDURE C34009A IS + + PACKAGE PKG IS + + TYPE PARENT IS PRIVATE; + + FUNCTION CREATE (X : INTEGER) RETURN PARENT; + + FUNCTION CON (X : INTEGER) RETURN PARENT; + + PRIVATE + + TYPE PARENT IS NEW INTEGER; + + END PKG; + + USE PKG; + + TYPE T IS NEW PARENT; + + X : T; + K : INTEGER := X'SIZE; + W : PARENT; + B : BOOLEAN := FALSE; + + PROCEDURE A (X : ADDRESS) IS + BEGIN + B := IDENT_BOOL (TRUE); + END A; + + PACKAGE BODY PKG IS + + FUNCTION CREATE (X : INTEGER) RETURN PARENT IS + BEGIN + RETURN PARENT (IDENT_INT (X)); + END CREATE; + + FUNCTION CON (X : INTEGER) RETURN PARENT IS + BEGIN + RETURN PARENT (X); + END CON; + + END PKG; + +BEGIN + TEST ("C34009A", "CHECK THAT THE REQUIRED PREDEFINED OPERATIONS " & + "ARE DECLARED (IMPLICITLY) FOR DERIVED " & + "NON-LIMITED PRIVATE TYPES WITHOUT " & + "DISCRIMINANTS"); + + X := CREATE (30); + IF X /= CON (30) THEN + FAILED ("INCORRECT :="); + END IF; + + IF T'(X) /= CON (30) THEN + FAILED ("INCORRECT QUALIFICATION"); + END IF; + + IF T (X) /= CON (30) THEN + FAILED ("INCORRECT SELF CONVERSION"); + END IF; + + W := CREATE (-30); + IF T (W) /= CON (-30) THEN + FAILED ("INCORRECT CONVERSION FROM PARENT"); + END IF; + + IF PARENT (X) /= CON (30) THEN + FAILED ("INCORRECT CONVERSION TO PARENT"); + END IF; + + IF X = CON (0) THEN + FAILED ("INCORRECT ="); + END IF; + + IF X /= CON (30) THEN + FAILED ("INCORRECT /="); + END IF; + + IF NOT (X IN T) THEN + FAILED ("INCORRECT ""IN"""); + END IF; + + IF X NOT IN T THEN + FAILED ("INCORRECT ""NOT IN"""); + END IF; + + B := FALSE; + A (X'ADDRESS); + IF NOT B THEN + FAILED ("INCORRECT 'ADDRESS"); + END IF; + + RESULT; +END C34009A; diff --git a/gcc-4.9/gcc/testsuite/ada/acats/tests/c3/c34009d.ada b/gcc-4.9/gcc/testsuite/ada/acats/tests/c3/c34009d.ada new file mode 100644 index 000000000..c65441f57 --- /dev/null +++ b/gcc-4.9/gcc/testsuite/ada/acats/tests/c3/c34009d.ada @@ -0,0 +1,226 @@ +-- C34009D.ADA + +-- Grant of Unlimited Rights +-- +-- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687, +-- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained +-- unlimited rights in the software and documentation contained herein. +-- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making +-- this public release, the Government intends to confer upon all +-- recipients unlimited rights equal to those held by the Government. +-- These rights include rights to use, duplicate, release or disclose the +-- released technical data and computer software in whole or in part, in +-- any manner and for any purpose whatsoever, and to have or permit others +-- to do so. +-- +-- DISCLAIMER +-- +-- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR +-- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED +-- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF 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 REQUIRED PREDEFINED OPERATIONS ARE DECLARED +-- (IMPLICITLY) FOR DERIVED NON-LIMITED PRIVATE TYPES WITH +-- DISCRIMINANTS. + +-- HISTORY: +-- JRK 08/31/87 CREATED ORIGINAL TEST. +-- WMC 03/13/92 REVISED TYPE'SIZE CHECKS. +-- PWN 01/31/95 REMOVED INCONSISTENCIES WITH ADA 9X. + +WITH SYSTEM; USE SYSTEM; +WITH REPORT; USE REPORT; + +PROCEDURE C34009D IS + + PACKAGE PKG IS + + MAX_LEN : CONSTANT := 10; + + SUBTYPE LENGTH IS NATURAL RANGE 0 .. MAX_LEN; + + TYPE PARENT (B : BOOLEAN := TRUE; L : LENGTH := 1) IS PRIVATE; + + FUNCTION CREATE ( B : BOOLEAN; + L : LENGTH; + I : INTEGER; + S : STRING; + J : INTEGER; + F : FLOAT; + X : PARENT -- TO RESOLVE OVERLOADING. + ) RETURN PARENT; + + FUNCTION CON ( B : BOOLEAN; + L : LENGTH; + I : INTEGER; + S : STRING; + J : INTEGER + ) RETURN PARENT; + + FUNCTION CON ( B : BOOLEAN; + L : LENGTH; + I : INTEGER; + F : FLOAT + ) RETURN PARENT; + + PRIVATE + + TYPE PARENT (B : BOOLEAN := TRUE; L : LENGTH := 1) IS + RECORD + I : INTEGER; + CASE B IS + WHEN TRUE => + S : STRING (1 .. L); + J : INTEGER; + WHEN FALSE => + F : FLOAT := 5.0; + END CASE; + END RECORD; + + END PKG; + + USE PKG; + + TYPE T IS NEW PARENT (IDENT_BOOL (TRUE), IDENT_INT (3)); + + X : T; + W : PARENT; + B : BOOLEAN := FALSE; + + PROCEDURE A (X : ADDRESS) IS + BEGIN + B := IDENT_BOOL (TRUE); + END A; + + PACKAGE BODY PKG IS + + FUNCTION CREATE + ( B : BOOLEAN; + L : LENGTH; + I : INTEGER; + S : STRING; + J : INTEGER; + F : FLOAT; + X : PARENT + ) RETURN PARENT + IS + BEGIN + CASE B IS + WHEN TRUE => + RETURN (TRUE, L, I, S, J); + WHEN FALSE => + RETURN (FALSE, L, I, F); + END CASE; + END CREATE; + + FUNCTION CON + ( B : BOOLEAN; + L : LENGTH; + I : INTEGER; + S : STRING; + J : INTEGER + ) RETURN PARENT + IS + BEGIN + RETURN (TRUE, L, I, S, J); + END CON; + + FUNCTION CON + ( B : BOOLEAN; + L : LENGTH; + I : INTEGER; + F : FLOAT + ) RETURN PARENT + IS + BEGIN + RETURN (FALSE, L, I, F); + END CON; + + END PKG; + +BEGIN + TEST ("C34009D", "CHECK THAT THE REQUIRED PREDEFINED OPERATIONS " & + "ARE DECLARED (IMPLICITLY) FOR DERIVED " & + "NON-LIMITED PRIVATE TYPES WITH DISCRIMINANTS"); + + X := CON (TRUE, 3, 2, "AAA", 2); + W := CON (TRUE, 3, 2, "AAA", 2); + + IF EQUAL (3, 3) THEN + X := CON (TRUE, 3, 1, "ABC", 4); + END IF; + IF X /= CON (TRUE, 3, 1, "ABC", 4) THEN + FAILED ("INCORRECT :="); + END IF; + + IF T'(X) /= CON (TRUE, 3, 1, "ABC", 4) THEN + FAILED ("INCORRECT QUALIFICATION"); + END IF; + + IF T (X) /= CON (TRUE, 3, 1, "ABC", 4) THEN + FAILED ("INCORRECT SELF CONVERSION"); + END IF; + + IF EQUAL (3, 3) THEN + W := CON (TRUE, 3, 1, "ABC", 4); + END IF; + IF T (W) /= CON (TRUE, 3, 1, "ABC", 4) THEN + FAILED ("INCORRECT CONVERSION FROM PARENT"); + END IF; + + IF PARENT (X) /= CON (TRUE, 3, 1, "ABC", 4) OR + PARENT (CREATE (FALSE, 2, 3, "XX", 5, 6.0, X)) /= + CON (FALSE, 2, 3, 6.0) THEN + FAILED ("INCORRECT CONVERSION TO PARENT"); + END IF; + + IF X.B /= TRUE OR X.L /= 3 OR + CREATE (FALSE, 2, 3, "XX", 5, 6.0, X) . B /= FALSE OR + CREATE (FALSE, 2, 3, "XX", 5, 6.0, X) . L /= 2 THEN + FAILED ("INCORRECT SELECTION (DISCRIMINANT)"); + END IF; + + IF X = CON (TRUE, 3, 1, "ABC", 5) OR + X = CON (FALSE, 2, 3, 6.0) THEN + FAILED ("INCORRECT ="); + END IF; + + IF X /= CON (TRUE, 3, 1, "ABC", 4) OR + NOT (X /= CON (FALSE, 2, 3, 6.0)) THEN + FAILED ("INCORRECT /="); + END IF; + + IF NOT (X IN T) OR CON (FALSE, 2, 3, 6.0) IN T THEN + FAILED ("INCORRECT ""IN"""); + END IF; + + IF X NOT IN T OR NOT (CON (FALSE, 2, 3, 6.0) NOT IN T) THEN + FAILED ("INCORRECT ""NOT IN"""); + END IF; + + B := FALSE; + A (X'ADDRESS); + IF NOT B THEN + FAILED ("INCORRECT 'ADDRESS"); + END IF; + + IF NOT X'CONSTRAINED THEN + FAILED ("INCORRECT OBJECT'CONSTRAINED"); + END IF; + + IF T'SIZE <= 0 THEN + FAILED ("INCORRECT TYPE'SIZE"); + END IF; + + IF X'SIZE < T'SIZE OR + X.B'SIZE < BOOLEAN'SIZE OR + X.L'SIZE < LENGTH'SIZE THEN + FAILED ("INCORRECT OBJECT'SIZE"); + END IF; + + RESULT; +END C34009D; diff --git a/gcc-4.9/gcc/testsuite/ada/acats/tests/c3/c34009f.ada b/gcc-4.9/gcc/testsuite/ada/acats/tests/c3/c34009f.ada new file mode 100644 index 000000000..63716c564 --- /dev/null +++ b/gcc-4.9/gcc/testsuite/ada/acats/tests/c3/c34009f.ada @@ -0,0 +1,256 @@ +-- C34009F.ADA + +-- Grant of Unlimited Rights +-- +-- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687, +-- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained +-- unlimited rights in the software and documentation contained herein. +-- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making +-- this public release, the Government intends to confer upon all +-- recipients unlimited rights equal to those held by the Government. +-- These rights include rights to use, duplicate, release or disclose the +-- released technical data and computer software in whole or in part, in +-- any manner and for any purpose whatsoever, and to have or permit others +-- to do so. +-- +-- DISCLAIMER +-- +-- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR +-- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED +-- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE +-- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE +-- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A +-- PARTICULAR PURPOSE OF SAID MATERIAL. +--* +-- OBJECTIVE: +-- FOR DERIVED NON-LIMITED PRIVATE TYPES WITH DISCRIMINANTS: + +-- CHECK THAT ALL VALUES OF THE PARENT (BASE) TYPE ARE PRESENT +-- FOR THE DERIVED (BASE) TYPE WHEN THE DERIVED TYPE DEFINITION +-- IS CONSTRAINED. + +-- CHECK THAT ANY CONSTRAINT IMPOSED ON THE PARENT SUBTYPE IS +-- ALSO IMPOSED ON THE DERIVED SUBTYPE. + +-- HISTORY: +-- JRK 08/31/87 CREATED ORIGINAL TEST. + +WITH REPORT; USE REPORT; + +PROCEDURE C34009F IS + + PACKAGE PKG IS + + MAX_LEN : CONSTANT := 10; + + SUBTYPE LENGTH IS NATURAL RANGE 0 .. MAX_LEN; + + TYPE PARENT (B : BOOLEAN := TRUE; L : LENGTH := 1) IS PRIVATE; + + FUNCTION CREATE ( B : BOOLEAN; + L : LENGTH; + I : INTEGER; + S : STRING; + J : INTEGER; + F : FLOAT; + X : PARENT -- TO RESOLVE OVERLOADING. + ) RETURN PARENT; + + FUNCTION CON ( B : BOOLEAN; + L : LENGTH; + I : INTEGER; + S : STRING; + J : INTEGER + ) RETURN PARENT; + + FUNCTION CON ( B : BOOLEAN; + L : LENGTH; + I : INTEGER; + F : FLOAT + ) RETURN PARENT; + + PRIVATE + + TYPE PARENT (B : BOOLEAN := TRUE; L : LENGTH := 1) IS + RECORD + I : INTEGER; + CASE B IS + WHEN TRUE => + S : STRING (1 .. L); + J : INTEGER; + WHEN FALSE => + F : FLOAT := 5.0; + END CASE; + END RECORD; + + END PKG; + + USE PKG; + + TYPE T IS NEW PARENT (IDENT_BOOL (TRUE), IDENT_INT (3)); + + SUBTYPE SUBPARENT IS PARENT (TRUE, 3); + + TYPE S IS NEW SUBPARENT; + + X : T; + Y : S; + + PACKAGE BODY PKG IS + + FUNCTION CREATE + ( B : BOOLEAN; + L : LENGTH; + I : INTEGER; + S : STRING; + J : INTEGER; + F : FLOAT; + X : PARENT + ) RETURN PARENT + IS + BEGIN + CASE B IS + WHEN TRUE => + RETURN (TRUE, L, I, S, J); + WHEN FALSE => + RETURN (FALSE, L, I, F); + END CASE; + END CREATE; + + FUNCTION CON + ( B : BOOLEAN; + L : LENGTH; + I : INTEGER; + S : STRING; + J : INTEGER + ) RETURN PARENT + IS + BEGIN + RETURN (TRUE, L, I, S, J); + END CON; + + FUNCTION CON + ( B : BOOLEAN; + L : LENGTH; + I : INTEGER; + F : FLOAT + ) RETURN PARENT + IS + BEGIN + RETURN (FALSE, L, I, F); + END CON; + + END PKG; + +BEGIN + TEST ("C34009F", "CHECK THAT ALL VALUES OF THE PARENT (BASE) " & + "TYPE ARE PRESENT FOR THE DERIVED (BASE) TYPE " & + "WHEN THE DERIVED TYPE DEFINITION IS " & + "CONSTRAINED. ALSO CHECK THAT ANY CONSTRAINT " & + "IMPOSED ON THE PARENT SUBTYPE IS ALSO IMPOSED " & + "ON THE DERIVED SUBTYPE. CHECK FOR DERIVED " & + "NON-LIMITED PRIVATE TYPES WITH DISCRIMINANTS"); + + X := CON (TRUE, 3, 2, "AAA", 2); + Y := CON (TRUE, 3, 2, "AAA", 2); + + -- CHECK THAT BASE TYPE VALUES NOT IN THE SUBTYPE ARE PRESENT. + + IF CREATE (FALSE, 2, 3, "ZZ", 5, 6.0, X) /= + CON (FALSE, 2, 3, 6.0) OR + CREATE (FALSE, 2, 3, "ZZ", 5, 6.0, Y) /= + CON (FALSE, 2, 3, 6.0) THEN + FAILED ("CAN'T CREATE BASE TYPE VALUES OUTSIDE THE SUBTYPE"); + END IF; + + IF CREATE (FALSE, 2, 3, "ZZ", 5, 6.0, X) IN T OR + CREATE (FALSE, 2, 3, "ZZ", 5, 6.0, Y) IN S THEN + FAILED ("INCORRECT ""IN"""); + END IF; + + -- CHECK THE DERIVED SUBTYPE CONSTRAINT. + + IF X.B /= TRUE OR X.L /= 3 OR + Y.B /= TRUE OR Y.L /= 3 THEN + FAILED ("INCORRECT SELECTION OF DISCRIMINANT VALUES"); + END IF; + + IF NOT X'CONSTRAINED OR NOT Y'CONSTRAINED THEN + FAILED ("INCORRECT 'CONSTRAINED"); + END IF; + + BEGIN + X := CON (TRUE, 3, 1, "ABC", 4); + Y := CON (TRUE, 3, 1, "ABC", 4); + IF PARENT (X) /= PARENT (Y) THEN -- USE X AND Y. + FAILED ("INCORRECT CONVERSION TO PARENT"); + END IF; + EXCEPTION + WHEN OTHERS => + FAILED ("EXCEPTION RAISED BY OK ASSIGNMENT"); + END; + + BEGIN + X := CON (FALSE, 3, 2, 6.0); + FAILED ("CONSTRAINT_ERROR NOT RAISED -- " & + "X := CON (FALSE, 3, 2, 6.0)"); + IF X = CON (FALSE, 3, 2, 6.0) THEN -- USE X. + COMMENT ("X ALTERED -- X := CON (FALSE, 3, 2, 6.0)"); + END IF; + EXCEPTION + WHEN CONSTRAINT_ERROR => + NULL; + WHEN OTHERS => + FAILED ("WRONG EXCEPTION RAISED -- " & + "X := CON (FALSE, 3, 2, 6.0)"); + END; + + BEGIN + X := CON (TRUE, 4, 2, "ZZZZ", 6); + FAILED ("CONSTRAINT_ERROR NOT RAISED -- " & + "X := CON (TRUE, 4, 2, ""ZZZZ"", 6)"); + IF X = CON (TRUE, 4, 2, "ZZZZ", 6) THEN -- USE X. + COMMENT ("X ALTERED -- " & + "X := CON (TRUE, 4, 2, ""ZZZZ"", 6)"); + END IF; + EXCEPTION + WHEN CONSTRAINT_ERROR => + NULL; + WHEN OTHERS => + FAILED ("WRONG EXCEPTION RAISED -- " & + "X := CON (TRUE, 4, 2, ""ZZZZ"", 6)"); + END; + + BEGIN + Y := CON (FALSE, 3, 2, 6.0); + FAILED ("CONSTRAINT_ERROR NOT RAISED -- " & + "Y := CON (FALSE, 3, 2, 6.0)"); + IF Y = CON (FALSE, 3, 2, 6.0) THEN -- USE Y. + COMMENT ("Y ALTERED -- Y := CON (FALSE, 3, 2, 6.0)"); + END IF; + EXCEPTION + WHEN CONSTRAINT_ERROR => + NULL; + WHEN OTHERS => + FAILED ("WRONG EXCEPTION RAISED -- " & + "Y := CON (FALSE, 3, 2, 6.0)"); + END; + + BEGIN + Y := CON (TRUE, 4, 2, "ZZZZ", 6); + FAILED ("CONSTRAINT_ERROR NOT RAISED -- " & + "Y := CON (TRUE, 4, 2, ""ZZZZ"", 6)"); + IF Y = CON (TRUE, 4, 2, "ZZZZ", 6) THEN -- USE Y. + COMMENT ("Y ALTERED -- " & + "Y := CON (TRUE, 4, 2, ""ZZZZ"", 6)"); + END IF; + EXCEPTION + WHEN CONSTRAINT_ERROR => + NULL; + WHEN OTHERS => + FAILED ("WRONG EXCEPTION RAISED -- " & + "Y := CON (TRUE, 4, 2, ""ZZZZ"", 6)"); + END; + + RESULT; +END C34009F; diff --git a/gcc-4.9/gcc/testsuite/ada/acats/tests/c3/c34009g.ada b/gcc-4.9/gcc/testsuite/ada/acats/tests/c3/c34009g.ada new file mode 100644 index 000000000..a225347a7 --- /dev/null +++ b/gcc-4.9/gcc/testsuite/ada/acats/tests/c3/c34009g.ada @@ -0,0 +1,137 @@ +-- C34009G.ADA + +-- Grant of Unlimited Rights +-- +-- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687, +-- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained +-- unlimited rights in the software and documentation contained herein. +-- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making +-- this public release, the Government intends to confer upon all +-- recipients unlimited rights equal to those held by the Government. +-- These rights include rights to use, duplicate, release or disclose the +-- released technical data and computer software in whole or in part, in +-- any manner and for any purpose whatsoever, and to have or permit others +-- to do so. +-- +-- DISCLAIMER +-- +-- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR +-- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED +-- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF 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 REQUIRED PREDEFINED OPERATIONS ARE DECLARED +-- (IMPLICITLY) FOR DERIVED LIMITED PRIVATE TYPES WITHOUT +-- DISCRIMINANTS. + +-- HISTORY: +-- JRK 09/01/87 CREATED ORIGINAL TEST. +-- PWN 11/30/94 REMOVED 'BASE USE ILLEGAL IN ADA 9X. +-- PWN 01/31/95 REMOVED INCONSISTENCIES WITH ADA 9X. + +WITH SYSTEM; USE SYSTEM; +WITH REPORT; USE REPORT; + +PROCEDURE C34009G IS + + PACKAGE PKG IS + + TYPE PARENT IS LIMITED PRIVATE; + + FUNCTION CREATE (X : INTEGER) RETURN PARENT; + + FUNCTION CON (X : INTEGER) RETURN PARENT; + + FUNCTION EQUAL (X, Y : PARENT) RETURN BOOLEAN; + + PROCEDURE ASSIGN (X : OUT PARENT; Y : PARENT); + + PRIVATE + + TYPE PARENT IS NEW INTEGER; + + END PKG; + + USE PKG; + + TYPE T IS NEW PARENT; + + X : T; + W : PARENT; + B : BOOLEAN := FALSE; + + PROCEDURE A (X : ADDRESS) IS + BEGIN + B := IDENT_BOOL (TRUE); + END A; + + PACKAGE BODY PKG IS + + FUNCTION CREATE (X : INTEGER) RETURN PARENT IS + BEGIN + RETURN PARENT (IDENT_INT (X)); + END CREATE; + + FUNCTION CON (X : INTEGER) RETURN PARENT IS + BEGIN + RETURN PARENT (X); + END CON; + + FUNCTION EQUAL (X, Y : PARENT) RETURN BOOLEAN IS + BEGIN + RETURN X = Y; + END EQUAL; + + PROCEDURE ASSIGN (X : OUT PARENT; Y : PARENT) IS + BEGIN + X := Y; + END ASSIGN; + + END PKG; + +BEGIN + TEST ("C34009G", "CHECK THAT THE REQUIRED PREDEFINED OPERATIONS " & + "ARE DECLARED (IMPLICITLY) FOR DERIVED " & + "LIMITED PRIVATE TYPES WITHOUT DISCRIMINANTS"); + + ASSIGN (X, CREATE (30)); + IF NOT EQUAL (T'(X), CON (30)) THEN + FAILED ("INCORRECT QUALIFICATION"); + END IF; + + IF NOT EQUAL (T (X), CON (30)) THEN + FAILED ("INCORRECT SELF CONVERSION"); + END IF; + + ASSIGN (W, CREATE (-30)); + IF NOT EQUAL (T (W), CON (-30)) THEN + FAILED ("INCORRECT CONVERSION FROM PARENT"); + END IF; + + IF NOT EQUAL (PARENT (X), CON (30)) THEN + FAILED ("INCORRECT CONVERSION TO PARENT"); + END IF; + + IF NOT (X IN T) THEN + FAILED ("INCORRECT ""IN"""); + END IF; + + IF X NOT IN T THEN + FAILED ("INCORRECT ""NOT IN"""); + END IF; + + B := FALSE; + A (X'ADDRESS); + IF NOT B THEN + FAILED ("INCORRECT 'ADDRESS"); + END IF; + + IF X'SIZE < T'SIZE THEN + FAILED ("INCORRECT OBJECT'SIZE"); + END IF; + + RESULT; +END C34009G; diff --git a/gcc-4.9/gcc/testsuite/ada/acats/tests/c3/c34009j.ada b/gcc-4.9/gcc/testsuite/ada/acats/tests/c3/c34009j.ada new file mode 100644 index 000000000..f095fad15 --- /dev/null +++ b/gcc-4.9/gcc/testsuite/ada/acats/tests/c3/c34009j.ada @@ -0,0 +1,225 @@ +-- C34009J.ADA + +-- Grant of Unlimited Rights +-- +-- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687, +-- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained +-- unlimited rights in the software and documentation contained herein. +-- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making +-- this public release, the Government intends to confer upon all +-- recipients unlimited rights equal to those held by the Government. +-- These rights include rights to use, duplicate, release or disclose the +-- released technical data and computer software in whole or in part, in +-- any manner and for any purpose whatsoever, and to have or permit others +-- to do so. +-- +-- DISCLAIMER +-- +-- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR +-- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED +-- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF 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 REQUIRED PREDEFINED OPERATIONS ARE DECLARED +-- (IMPLICITLY) FOR DERIVED LIMITED PRIVATE TYPES WITH +-- DISCRIMINANTS. + +-- HISTORY: +-- JRK 09/01/87 CREATED ORIGINAL TEST. +-- WMC 03/13/92 REVISED TYPE'SIZE CHECKS. +-- PWN 01/31/95 REMOVED INCONSISTENCIES WITH ADA 9X. + +WITH SYSTEM; USE SYSTEM; +WITH REPORT; USE REPORT; + +PROCEDURE C34009J IS + + PACKAGE PKG IS + + MAX_LEN : CONSTANT := 10; + + SUBTYPE LENGTH IS NATURAL RANGE 0 .. MAX_LEN; + + TYPE PARENT (B : BOOLEAN := TRUE; L : LENGTH := 3) IS + LIMITED PRIVATE; + + FUNCTION CREATE ( B : BOOLEAN; + L : LENGTH; + I : INTEGER; + S : STRING; + J : INTEGER; + F : FLOAT; + X : PARENT -- TO RESOLVE OVERLOADING. + ) RETURN PARENT; + + FUNCTION CON ( B : BOOLEAN; + L : LENGTH; + I : INTEGER; + S : STRING; + J : INTEGER + ) RETURN PARENT; + + FUNCTION CON ( B : BOOLEAN; + L : LENGTH; + I : INTEGER; + F : FLOAT + ) RETURN PARENT; + + FUNCTION EQUAL (X, Y : PARENT) RETURN BOOLEAN; + + PROCEDURE ASSIGN (X : OUT PARENT; Y : PARENT); + + PRIVATE + + TYPE PARENT (B : BOOLEAN := TRUE; L : LENGTH := 3) IS + RECORD + I : INTEGER := 2; + CASE B IS + WHEN TRUE => + S : STRING (1 .. L) := (1 .. L => 'A'); + J : INTEGER := 2; + WHEN FALSE => + F : FLOAT := 5.0; + END CASE; + END RECORD; + + END PKG; + + USE PKG; + + TYPE T IS NEW PARENT (IDENT_BOOL (TRUE), IDENT_INT (3)); + + X : T; + W : PARENT; + B : BOOLEAN := FALSE; + + PROCEDURE A (X : ADDRESS) IS + BEGIN + B := IDENT_BOOL (TRUE); + END A; + + PACKAGE BODY PKG IS + + FUNCTION CREATE + ( B : BOOLEAN; + L : LENGTH; + I : INTEGER; + S : STRING; + J : INTEGER; + F : FLOAT; + X : PARENT + ) RETURN PARENT + IS + BEGIN + CASE B IS + WHEN TRUE => + RETURN (TRUE, L, I, S, J); + WHEN FALSE => + RETURN (FALSE, L, I, F); + END CASE; + END CREATE; + + FUNCTION CON + ( B : BOOLEAN; + L : LENGTH; + I : INTEGER; + S : STRING; + J : INTEGER + ) RETURN PARENT + IS + BEGIN + RETURN (TRUE, L, I, S, J); + END CON; + + FUNCTION CON + ( B : BOOLEAN; + L : LENGTH; + I : INTEGER; + F : FLOAT + ) RETURN PARENT + IS + BEGIN + RETURN (FALSE, L, I, F); + END CON; + + FUNCTION EQUAL (X, Y : PARENT) RETURN BOOLEAN IS + BEGIN + RETURN X = Y; + END EQUAL; + + PROCEDURE ASSIGN (X : OUT PARENT; Y : PARENT) IS + BEGIN + X := Y; + END ASSIGN; + + END PKG; + +BEGIN + TEST ("C34009J", "CHECK THAT THE REQUIRED PREDEFINED OPERATIONS " & + "ARE DECLARED (IMPLICITLY) FOR DERIVED " & + "LIMITED PRIVATE TYPES WITH DISCRIMINANTS"); + + IF EQUAL (3, 3) THEN + ASSIGN (X, CON (TRUE, 3, 1, "ABC", 4)); + END IF; + IF NOT EQUAL (T'(X), CON (TRUE, 3, 1, "ABC", 4)) THEN + FAILED ("INCORRECT QUALIFICATION"); + END IF; + + IF NOT EQUAL (T (X), CON (TRUE, 3, 1, "ABC", 4)) THEN + FAILED ("INCORRECT SELF CONVERSION"); + END IF; + + IF EQUAL (3, 3) THEN + ASSIGN (W, CON (TRUE, 3, 1, "ABC", 4)); + END IF; + IF NOT EQUAL (T (W), CON (TRUE, 3, 1, "ABC", 4)) THEN + FAILED ("INCORRECT CONVERSION FROM PARENT"); + END IF; + + IF NOT EQUAL (PARENT (X), CON (TRUE, 3, 1, "ABC", 4)) OR + NOT EQUAL (PARENT (CREATE (FALSE, 2, 3, "XX", 5, 6.0, X)), + CON (FALSE, 2, 3, 6.0)) THEN + FAILED ("INCORRECT CONVERSION TO PARENT"); + END IF; + + IF X.B /= TRUE OR X.L /= 3 OR + CREATE (FALSE, 2, 3, "XX", 5, 6.0, X) . B /= FALSE OR + CREATE (FALSE, 2, 3, "XX", 5, 6.0, X) . L /= 2 THEN + FAILED ("INCORRECT SELECTION (DISCRIMINANT)"); + END IF; + + IF NOT (X IN T) OR CON (FALSE, 2, 3, 6.0) IN T THEN + FAILED ("INCORRECT ""IN"""); + END IF; + + IF X NOT IN T OR NOT (CON (FALSE, 2, 3, 6.0) NOT IN T) THEN + FAILED ("INCORRECT ""NOT IN"""); + END IF; + + B := FALSE; + A (X'ADDRESS); + IF NOT B THEN + FAILED ("INCORRECT 'ADDRESS"); + END IF; + + + IF NOT X'CONSTRAINED THEN + FAILED ("INCORRECT OBJECT'CONSTRAINED"); + END IF; + + IF T'SIZE <= 0 THEN + FAILED ("INCORRECT TYPE'SIZE"); + END IF; + + IF X'SIZE < T'SIZE OR + X.B'SIZE < BOOLEAN'SIZE OR + X.L'SIZE < LENGTH'SIZE THEN + FAILED ("INCORRECT OBJECT'SIZE"); + END IF; + + RESULT; +END C34009J; diff --git a/gcc-4.9/gcc/testsuite/ada/acats/tests/c3/c34009l.ada b/gcc-4.9/gcc/testsuite/ada/acats/tests/c3/c34009l.ada new file mode 100644 index 000000000..71a02f28b --- /dev/null +++ b/gcc-4.9/gcc/testsuite/ada/acats/tests/c3/c34009l.ada @@ -0,0 +1,270 @@ +-- C34009L.ADA + +-- Grant of Unlimited Rights +-- +-- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687, +-- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained +-- unlimited rights in the software and documentation contained herein. +-- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making +-- this public release, the Government intends to confer upon all +-- recipients unlimited rights equal to those held by the Government. +-- These rights include rights to use, duplicate, release or disclose the +-- released technical data and computer software in whole or in part, in +-- any manner and for any purpose whatsoever, and to have or permit others +-- to do so. +-- +-- DISCLAIMER +-- +-- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR +-- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED +-- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE +-- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE +-- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A +-- PARTICULAR PURPOSE OF SAID MATERIAL. +--* +-- OBJECTIVE: +-- FOR DERIVED LIMITED PRIVATE TYPES WITH DISCRIMINANTS: + +-- CHECK THAT ALL VALUES OF THE PARENT (BASE) TYPE ARE PRESENT +-- FOR THE DERIVED (BASE) TYPE WHEN THE DERIVED TYPE DEFINITION +-- IS CONSTRAINED. + +-- CHECK THAT ANY CONSTRAINT IMPOSED ON THE PARENT SUBTYPE IS +-- ALSO IMPOSED ON THE DERIVED SUBTYPE. + +-- HISTORY: +-- JRK 09/01/87 CREATED ORIGINAL TEST. + +WITH REPORT; USE REPORT; + +PROCEDURE C34009L IS + + PACKAGE PKG IS + + MAX_LEN : CONSTANT := 10; + + SUBTYPE LENGTH IS NATURAL RANGE 0 .. MAX_LEN; + + TYPE PARENT (B : BOOLEAN := TRUE; L : LENGTH := 3) IS + LIMITED PRIVATE; + + FUNCTION CREATE ( B : BOOLEAN; + L : LENGTH; + I : INTEGER; + S : STRING; + J : INTEGER; + F : FLOAT; + X : PARENT -- TO RESOLVE OVERLOADING. + ) RETURN PARENT; + + FUNCTION CON ( B : BOOLEAN; + L : LENGTH; + I : INTEGER; + S : STRING; + J : INTEGER + ) RETURN PARENT; + + FUNCTION CON ( B : BOOLEAN; + L : LENGTH; + I : INTEGER; + F : FLOAT + ) RETURN PARENT; + + FUNCTION EQUAL (X, Y : PARENT) RETURN BOOLEAN; + + PROCEDURE ASSIGN (X : OUT PARENT; Y : PARENT); + + PRIVATE + + TYPE PARENT (B : BOOLEAN := TRUE; L : LENGTH := 3) IS + RECORD + I : INTEGER := 2; + CASE B IS + WHEN TRUE => + S : STRING (1 .. L) := (1 .. L => 'A'); + J : INTEGER := 2; + WHEN FALSE => + F : FLOAT := 5.0; + END CASE; + END RECORD; + + END PKG; + + USE PKG; + + TYPE T IS NEW PARENT (IDENT_BOOL (TRUE), IDENT_INT (3)); + + SUBTYPE SUBPARENT IS PARENT (TRUE, 3); + + TYPE S IS NEW SUBPARENT; + + X : T; + Y : S; + + PACKAGE BODY PKG IS + + FUNCTION CREATE + ( B : BOOLEAN; + L : LENGTH; + I : INTEGER; + S : STRING; + J : INTEGER; + F : FLOAT; + X : PARENT + ) RETURN PARENT + IS + BEGIN + CASE B IS + WHEN TRUE => + RETURN (TRUE, L, I, S, J); + WHEN FALSE => + RETURN (FALSE, L, I, F); + END CASE; + END CREATE; + + FUNCTION CON + ( B : BOOLEAN; + L : LENGTH; + I : INTEGER; + S : STRING; + J : INTEGER + ) RETURN PARENT + IS + BEGIN + RETURN (TRUE, L, I, S, J); + END CON; + + FUNCTION CON + ( B : BOOLEAN; + L : LENGTH; + I : INTEGER; + F : FLOAT + ) RETURN PARENT + IS + BEGIN + RETURN (FALSE, L, I, F); + END CON; + + FUNCTION EQUAL (X, Y : PARENT) RETURN BOOLEAN IS + BEGIN + RETURN X = Y; + END EQUAL; + + PROCEDURE ASSIGN (X : OUT PARENT; Y : PARENT) IS + BEGIN + X := Y; + END ASSIGN; + + END PKG; + +BEGIN + TEST ("C34009L", "CHECK THAT ALL VALUES OF THE PARENT (BASE) " & + "TYPE ARE PRESENT FOR THE DERIVED (BASE) TYPE " & + "WHEN THE DERIVED TYPE DEFINITION IS " & + "CONSTRAINED. ALSO CHECK THAT ANY CONSTRAINT " & + "IMPOSED ON THE PARENT SUBTYPE IS ALSO IMPOSED " & + "ON THE DERIVED SUBTYPE. CHECK FOR DERIVED " & + "LIMITED PRIVATE TYPES WITH DISCRIMINANTS"); + + -- CHECK THAT BASE TYPE VALUES NOT IN THE SUBTYPE ARE PRESENT. + + IF NOT EQUAL (CREATE (FALSE, 2, 3, "ZZ", 5, 6.0, X), + CON (FALSE, 2, 3, 6.0)) OR + NOT EQUAL (CREATE (FALSE, 2, 3, "ZZ", 5, 6.0, Y), + CON (FALSE, 2, 3, 6.0)) THEN + FAILED ("CAN'T CREATE BASE TYPE VALUES OUTSIDE THE SUBTYPE"); + END IF; + + IF CREATE (FALSE, 2, 3, "ZZ", 5, 6.0, X) IN T OR + CREATE (FALSE, 2, 3, "ZZ", 5, 6.0, Y) IN S THEN + FAILED ("INCORRECT ""IN"""); + END IF; + + -- CHECK THE DERIVED SUBTYPE CONSTRAINT. + + IF X.B /= TRUE OR X.L /= 3 OR + Y.B /= TRUE OR Y.L /= 3 THEN + FAILED ("INCORRECT SELECTION OF DISCRIMINANT VALUES"); + END IF; + + IF NOT X'CONSTRAINED OR NOT Y'CONSTRAINED THEN + FAILED ("INCORRECT 'CONSTRAINED"); + END IF; + + BEGIN + ASSIGN (X, CON (TRUE, 3, 1, "ABC", 4)); + ASSIGN (Y, CON (TRUE, 3, 1, "ABC", 4)); + IF NOT EQUAL (PARENT (X), PARENT (Y)) THEN -- USE X AND Y. + FAILED ("INCORRECT CONVERSION TO PARENT"); + END IF; + EXCEPTION + WHEN OTHERS => + FAILED ("EXCEPTION RAISED BY OK ASSIGN CALL"); + END; + + BEGIN + ASSIGN (X, CON (FALSE, 3, 2, 6.0)); + FAILED ("CONSTRAINT_ERROR NOT RAISED -- " & + "ASSIGN (X, CON (FALSE, 3, 2, 6.0))"); + IF EQUAL (X, CON (FALSE, 3, 2, 6.0)) THEN -- USE X. + COMMENT ("X ALTERED -- " & + "ASSIGN (X, CON (FALSE, 3, 2, 6.0))"); + END IF; + EXCEPTION + WHEN CONSTRAINT_ERROR => + NULL; + WHEN OTHERS => + FAILED ("WRONG EXCEPTION RAISED -- " & + "ASSIGN (X, CON (FALSE, 3, 2, 6.0))"); + END; + + BEGIN + ASSIGN (X, CON (TRUE, 4, 2, "ZZZZ", 6)); + FAILED ("CONSTRAINT_ERROR NOT RAISED -- " & + "ASSIGN (X, CON (TRUE, 4, 2, ""ZZZZ"", 6))"); + IF EQUAL (X, CON (TRUE, 4, 2, "ZZZZ", 6)) THEN -- USE X. + COMMENT ("X ALTERED -- " & + "ASSIGN (X, CON (TRUE, 4, 2, ""ZZZZ"", 6))"); + END IF; + EXCEPTION + WHEN CONSTRAINT_ERROR => + NULL; + WHEN OTHERS => + FAILED ("WRONG EXCEPTION RAISED -- " & + "ASSIGN (X, CON (TRUE, 4, 2, ""ZZZZ"", 6))"); + END; + + BEGIN + ASSIGN (Y, CON (FALSE, 3, 2, 6.0)); + FAILED ("CONSTRAINT_ERROR NOT RAISED -- " & + "ASSIGN (Y, CON (FALSE, 3, 2, 6.0))"); + IF EQUAL (Y, CON (FALSE, 3, 2, 6.0)) THEN -- USE Y. + COMMENT ("Y ALTERED -- " & + "ASSIGN (Y, CON (FALSE, 3, 2, 6.0))"); + END IF; + EXCEPTION + WHEN CONSTRAINT_ERROR => + NULL; + WHEN OTHERS => + FAILED ("WRONG EXCEPTION RAISED -- " & + "ASSIGN (Y, CON (FALSE, 3, 2, 6.0))"); + END; + + BEGIN + ASSIGN (Y, CON (TRUE, 4, 2, "ZZZZ", 6)); + FAILED ("CONSTRAINT_ERROR NOT RAISED -- " & + "ASSIGN (Y, CON (TRUE, 4, 2, ""ZZZZ"", 6))"); + IF EQUAL (Y, CON (TRUE, 4, 2, "ZZZZ", 6)) THEN -- USE Y. + COMMENT ("Y ALTERED -- " & + "ASSIGN (Y, CON (TRUE, 4, 2, ""ZZZZ"", 6))"); + END IF; + EXCEPTION + WHEN CONSTRAINT_ERROR => + NULL; + WHEN OTHERS => + FAILED ("WRONG EXCEPTION RAISED -- " & + "ASSIGN (Y, CON (TRUE, 4, 2, ""ZZZZ"", 6))"); + END; + + RESULT; +END C34009L; diff --git a/gcc-4.9/gcc/testsuite/ada/acats/tests/c3/c34011b.ada b/gcc-4.9/gcc/testsuite/ada/acats/tests/c3/c34011b.ada new file mode 100644 index 000000000..47e260090 --- /dev/null +++ b/gcc-4.9/gcc/testsuite/ada/acats/tests/c3/c34011b.ada @@ -0,0 +1,343 @@ +-- C34011B.ADA + +-- Grant of Unlimited Rights +-- +-- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687, +-- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained +-- unlimited rights in the software and documentation contained herein. +-- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making +-- this public release, the Government intends to confer upon all +-- recipients unlimited rights equal to those held by the Government. +-- These rights include rights to use, duplicate, release or disclose the +-- released technical data and computer software in whole or in part, in +-- any manner and for any purpose whatsoever, and to have or permit others +-- to do so. +-- +-- DISCLAIMER +-- +-- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR +-- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED +-- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF 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 DERIVED TYPE DECLARATION IS NOT CONSIDERED EXACTLY +-- EQUIVALENT TO AN ANONYMOUS DECLARATION OF THE DERIVED TYPE +-- FOLLOWED BY A SUBTYPE DECLARATION OF THE DERIVED SUBTYPE. IN +-- PARTICULAR, CHECK THAT CONSTRAINT_ERROR CAN BE RAISED WHEN THE +-- SUBTYPE INDICATION OF THE DERIVED TYPE DECLARATION IS ELABORATED +-- (EVEN THOUGH THE CONSTRAINT WOULD SATISFY THE DERIVED (BASE) +-- TYPE). + +-- HISTORY: +-- JRK 09/04/87 CREATED ORIGINAL TEST. +-- EDS 07/29/98 AVOID OPTIMIZATION + +WITH REPORT; USE REPORT; + +PROCEDURE C34011B IS + + SUBTYPE BOOL IS BOOLEAN RANGE FALSE .. FALSE; + + SUBTYPE FLT IS FLOAT RANGE -10.0 .. 10.0; + + SUBTYPE DUR IS DURATION RANGE 0.0 .. 10.0; + + SUBTYPE INT IS INTEGER RANGE 0 .. 10; + + TYPE ARR IS ARRAY (INT RANGE <>) OF INTEGER; + + TYPE REC (D : INT := 0) IS + RECORD + I : INTEGER; + END RECORD; + + PACKAGE PT IS + TYPE PRIV (D : POSITIVE := 1) IS PRIVATE; + PRIVATE + TYPE PRIV (D : POSITIVE := 1) IS + RECORD + I : INTEGER; + END RECORD; + END PT; + + USE PT; + + TYPE ACC_ARR IS ACCESS ARR; + + TYPE ACC_REC IS ACCESS REC; + +BEGIN + TEST ("C34011B", "CHECK THAT CONSTRAINT_ERROR CAN BE RAISED " & + "WHEN THE SUBTYPE INDICATION OF A DERIVED TYPE " & + "DECLARATION IS ELABORATED"); + + BEGIN + DECLARE + TYPE T IS NEW BOOL RANGE FALSE .. BOOL(IDENT_BOOL(TRUE)); + + BEGIN + DECLARE + -- DEFINE AN OBJECT OF TYPE T AND USE IT TO AVOID OPTIMIZATION + T1 : T := T(IDENT_BOOL(TRUE)); + BEGIN + FAILED ("DID NOT RAISE CONSTRAINT_ERROR AT PROPER PLACE"); + EXCEPTION + WHEN OTHERS => + FAILED ("DID NOT RAISE CONSTRAINT_ERROR" & + " AT PROPER PLACE - BOOL " & + T'IMAGE(T1) ); --USE T1); + END; + + FAILED ("EXCEPTION NOT RAISED - BOOL"); + + EXCEPTION + WHEN OTHERS => + FAILED ("WRONG HANDLER ENTERED - BOOL"); + END; + + EXCEPTION + WHEN CONSTRAINT_ERROR => + NULL; + WHEN OTHERS => + FAILED ("WRONG EXCEPTION RAISED - BOOL"); + END; + + BEGIN + DECLARE + TYPE T IS NEW POSITIVE RANGE IDENT_INT (0) .. 10; + + BEGIN + DECLARE + -- DEFINE AN OBJECT OF TYPE T AND USE IT TO AVOID OPTIMIZATION + T1 : T := T(IDENT_INT(1)); + BEGIN + FAILED ("DID NOT RAISE CONSTRAINT_ERROR AT PROPER PLACE"); + EXCEPTION + WHEN OTHERS => + FAILED ("DID NOT RAISE CONSTRAINT_ERROR - POSITIVE " & + T'IMAGE(T1)); --USE T1 + END; + FAILED ("EXCEPTION NOT RAISED - POSITIVE" ); + EXCEPTION + WHEN OTHERS => + FAILED ("WRONG HANDLER ENTERED - POSITIVE"); + END; + + EXCEPTION + WHEN CONSTRAINT_ERROR => + NULL; + WHEN OTHERS => + FAILED ("WRONG EXCEPTION RAISED - POSITIVE"); + END; + + BEGIN + DECLARE + TYPE T IS NEW FLT RANGE 0.0 .. FLT(IDENT_INT(20)); + + BEGIN + DECLARE + -- DEFINE AN OBJECT OF TYPE T AND USE IT TO AVOID OPTIMIZATION + T1 : T := T(IDENT_INT(0)); + BEGIN + FAILED ("DID NOT RAISE CONSTRAINT_ERROR" & + " AT PROPER PLACE " & + T'IMAGE(T1) ); --USE T1 + + EXCEPTION + WHEN OTHERS => + FAILED ("DID NOT RAISE CONSTRAINT_ERROR" & + " AT PROPER PLACE "); + END; + FAILED ("EXCEPTION NOT RAISED - FLT" ); + EXCEPTION + WHEN OTHERS => + FAILED ("WRONG HANDLER ENTERED - FLT"); + END; + + EXCEPTION + WHEN CONSTRAINT_ERROR => + NULL; + WHEN OTHERS => + FAILED ("WRONG EXCEPTION RAISED - FLT"); + END; + + BEGIN + DECLARE + TYPE T IS NEW DUR RANGE DUR(IDENT_INT(-1)) .. 5.0; + + + BEGIN + DECLARE + -- DEFINE AN OBJECT OF TYPE T AND USE IT TO AVOID OPTIMIZATION + T1 : T := T(IDENT_INT(2)); + BEGIN + FAILED ("DID NOT RAISE CONSTRAINT_ERROR" & + " AT PROPER PLACE " & + T'IMAGE(T1) ); -- USE T1 + EXCEPTION + WHEN OTHERS => + FAILED ("DID NOT RAISE CONSTRAINT_ERROR AT PROPER PLACE"); + END; + FAILED ("EXCEPTION NOT RAISED - DUR " ); + EXCEPTION + WHEN OTHERS => + FAILED ("WRONG HANDLER ENTERED - DUR"); + END; + + EXCEPTION + WHEN CONSTRAINT_ERROR => + NULL; + WHEN OTHERS => + FAILED ("WRONG EXCEPTION RAISED - DUR"); + END; + + BEGIN + DECLARE + TYPE T IS NEW ARR (IDENT_INT (-1) .. 10); + + BEGIN + DECLARE + -- DEFINE AN OBJECT OF TYPE T AND USE IT TO AVOID OPTIMIZATION + T1 : T := (OTHERS => IDENT_INT(3)); + BEGIN + FAILED ("DID NOT RAISE CONSTRAINT_ERROR " & + "AT PROPER PLACE " & + INTEGER'IMAGE(T1(1)) ); --USE T1 + EXCEPTION + WHEN OTHERS => + FAILED ("DID NOT RAISE CONSTRAINT_ERROR AT PROPER PLACE"); + END; + FAILED ("EXCEPTION NOT RAISED - ARR " ); + EXCEPTION + WHEN OTHERS => + FAILED ("WRONG HANDLER ENTERED - ARR"); + END; + + EXCEPTION + WHEN CONSTRAINT_ERROR => + NULL; + WHEN OTHERS => + FAILED ("WRONG EXCEPTION RAISED - ARR"); + END; + + BEGIN + DECLARE + TYPE T IS NEW REC (IDENT_INT (11)); + + BEGIN + DECLARE + -- DEFINE AN OBJECT OF TYPE T AND USE IT TO AVOID OPTIMIZATION + T1 : T; + BEGIN + FAILED ("DID NOT RAISE CONSTRAINT_ERROR AT PROPER PLACE"); + EXCEPTION + WHEN OTHERS => + FAILED ("DID NOT RAISE CONSTRAINT_ERROR " & + "AT PROPER PLACE " & + INTEGER'IMAGE(T1.D) ); --USE T1 + END; + FAILED ("EXCEPTION NOT RAISED - REC " ); + EXCEPTION + WHEN OTHERS => + FAILED ("WRONG HANDLER ENTERED - REC"); + END; + + EXCEPTION + WHEN CONSTRAINT_ERROR => + NULL; + WHEN OTHERS => + FAILED ("WRONG EXCEPTION RAISED - REC"); + END; + + BEGIN + DECLARE + TYPE T IS NEW PRIV (IDENT_INT (0)); --RAISES C_E + + BEGIN + DECLARE + -- DEFINE AN OBJECT OF TYPE T AND USE IT TO AVOID OPTIMIZATION + T1 : T; + BEGIN + FAILED ("DID NOT RAISE CONSTRAINT_ERROR AT PROPER PLACE"); + EXCEPTION + WHEN OTHERS => + FAILED ("DID NOT RAISE CONSTRAINT_ERROR " & + "AT PROPER PLACE " & + INTEGER'IMAGE(T1.D) ); --USE T1 + END; + FAILED ("EXCEPTION NOT RAISED - PRIV " ); + EXCEPTION + WHEN OTHERS => + FAILED ("WRONG HANDLER ENTERED - PRIV"); + END; + + EXCEPTION + WHEN CONSTRAINT_ERROR => + NULL; + WHEN OTHERS => + FAILED ("WRONG EXCEPTION RAISED - PRIV"); + END; + + BEGIN + DECLARE + TYPE T IS NEW ACC_ARR (0 .. IDENT_INT (11)); --RAISES C_E + + BEGIN + DECLARE + -- DEFINE AN OBJECT OF TYPE T AND USE IT TO AVOID OPTIMIZATION + T1 : T; + BEGIN + FAILED ("DID NOT RAISE CONSTRAINT_ERROR AT PROPER PLACE"); + EXCEPTION + WHEN OTHERS => + FAILED ("DID NOT RAISE CONSTRAINT_ERROR " & + "AT PROPER PLACE " & + INTEGER'IMAGE(T1(1)) ); --USE T1 + END; + FAILED ("EXCEPTION NOT RAISED - ACC_ARR " ); + EXCEPTION + WHEN OTHERS => + FAILED ("WRONG HANDLER ENTERED - ACC_ARR"); + END; + + EXCEPTION + WHEN CONSTRAINT_ERROR => + NULL; + WHEN OTHERS => + FAILED ("WRONG EXCEPTION RAISED - ACC_ARR"); + END; + + BEGIN + DECLARE + TYPE T IS NEW ACC_REC (IDENT_INT (-1)); --RAISES C_E + + BEGIN + DECLARE + -- DEFINE AN OBJECT OF TYPE T AND USE IT TO AVOID OPTIMIZATION + T1 : T; + BEGIN + FAILED ("DID NOT RAISE CONSTRAINT_ERROR AT PROPER PLACE"); + EXCEPTION + WHEN OTHERS => + FAILED ("DID NOT RAISE CONSTRAINT_ERROR " & + "AT PROPER PLACE " & + INTEGER'IMAGE(T1.D) ); --USE T1 + END; + FAILED ("EXCEPTION NOT RAISED - ACC_REC " ); + EXCEPTION + WHEN OTHERS => + FAILED ("WRONG HANDLER ENTERED - ACC_REC"); + END; + + EXCEPTION + WHEN CONSTRAINT_ERROR => + NULL; + WHEN OTHERS => + FAILED ("WRONG EXCEPTION RAISED - ACC_REC"); + END; + + RESULT; +END C34011B; diff --git a/gcc-4.9/gcc/testsuite/ada/acats/tests/c3/c34012a.ada b/gcc-4.9/gcc/testsuite/ada/acats/tests/c3/c34012a.ada new file mode 100644 index 000000000..020b79b42 --- /dev/null +++ b/gcc-4.9/gcc/testsuite/ada/acats/tests/c3/c34012a.ada @@ -0,0 +1,136 @@ +-- C34012A.ADA + +-- Grant of Unlimited Rights +-- +-- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687, +-- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained +-- unlimited rights in the software and documentation contained herein. +-- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making +-- this public release, the Government intends to confer upon all +-- recipients unlimited rights equal to those held by the Government. +-- These rights include rights to use, duplicate, release or disclose the +-- released technical data and computer software in whole or in part, in +-- any manner and for any purpose whatsoever, and to have or permit others +-- to do so. +-- +-- DISCLAIMER +-- +-- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR +-- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED +-- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF 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 DEFAULT EXPRESSIONS IN DERIVED RECORD TYPES AND +-- DERIVED SUBPROGRAMS ARE EVALUATED USING THE ENTITIES DENOTED BY +-- THE EXPRESSIONS IN THE PARENT TYPE. + +-- HISTORY: +-- RJW 06/19/86 CREATED ORIGINAL TEST. +-- BCB 08/19/87 CHANGED HEADER TO STANDARD HEADER FORMAT. CHANGED +-- PACKAGE B SO WOULD HAVE ONE CASE WHERE DEFAULT IS +-- DECLARED BEFORE THE DERIVED TYPE DECLARATION. + +WITH REPORT; USE REPORT; + +PROCEDURE C34012A IS + +BEGIN + TEST ("C34012A", "CHECK THAT DEFAULT EXPRESSIONS IN DERIVED " & + "RECORD TYPES AND DERIVED SUBPROGRAMS ARE " & + "EVALUATED USING THE ENTITIES DENOTED BY THE " & + "EXPRESSIONS IN THE PARENT TYPE" ); + + DECLARE + PACKAGE P IS + X : INTEGER := 5; + TYPE REC IS + RECORD + C : INTEGER := X; + END RECORD; + END P; + + PACKAGE Q IS + X : INTEGER := 6; + TYPE NEW_REC IS NEW P.REC; + QVAR : NEW_REC; + END Q; + + PACKAGE R IS + X : INTEGER := 7; + TYPE BRAND_NEW_REC IS NEW Q.NEW_REC; + RVAR : BRAND_NEW_REC; + END R; + + USE Q; + USE R; + BEGIN + IF QVAR.C = 5 THEN + NULL; + ELSE + FAILED ( "INCORRECT VALUE FOR QVAR" ); + END IF; + + IF RVAR.C = 5 THEN + NULL; + ELSE + FAILED ( "INCORRECT VALUE FOR RVAR" ); + END IF; + END; + + DECLARE + PACKAGE A IS + TYPE T IS RANGE 1 .. 10; + DEFAULT : T := 5; + FUNCTION F (X : T := DEFAULT) RETURN T; + END A; + + PACKAGE BODY A IS + FUNCTION F (X : T := DEFAULT) RETURN T IS + BEGIN + RETURN X; + END F; + END A; + + PACKAGE B IS + DEFAULT : A.T:= 6; + TYPE NEW_T IS NEW A.T; + BVAR : NEW_T := F; + END B; + + PACKAGE C IS + TYPE BRAND_NEW_T IS NEW B.NEW_T; + DEFAULT : BRAND_NEW_T := 7; + CVAR : BRAND_NEW_T :=F; + END C; + + USE B; + USE C; + BEGIN + IF BVAR = 5 THEN + NULL; + ELSE + FAILED ( "INCORRECT VALUE FOR BVAR" ); + END IF; + + IF CVAR = 5 THEN + NULL; + ELSE + FAILED ( "INCORRECT VALUE FOR CVAR" ); + END IF; + + DECLARE + VAR : BRAND_NEW_T := F; + BEGIN + IF VAR = 5 THEN + NULL; + ELSE + FAILED ( "INCORRECT VALUE FOR VAR" ); + END IF; + END; + END; + + RESULT; +END C34012A; diff --git a/gcc-4.9/gcc/testsuite/ada/acats/tests/c3/c34014a.ada b/gcc-4.9/gcc/testsuite/ada/acats/tests/c3/c34014a.ada new file mode 100644 index 000000000..e2a917e6d --- /dev/null +++ b/gcc-4.9/gcc/testsuite/ada/acats/tests/c3/c34014a.ada @@ -0,0 +1,256 @@ +-- C34014A.ADA + +-- Grant of Unlimited Rights +-- +-- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687, +-- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained +-- unlimited rights in the software and documentation contained herein. +-- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making +-- this public release, the Government intends to confer upon all +-- recipients unlimited rights equal to those held by the Government. +-- These rights include rights to use, duplicate, release or disclose the +-- released technical data and computer software in whole or in part, in +-- any manner and for any purpose whatsoever, and to have or permit others +-- to do so. +-- +-- DISCLAIMER +-- +-- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR +-- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED +-- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF 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 DERIVED SUBPROGRAM IS VISIBLE AND FURTHER DERIVABLE +-- UNDER APPROPRIATE CIRCUMSTANCES. + +-- CHECK WHEN THE DERIVED SUBPROGRAM IS IMPLICITLY DECLARED IN THE +-- VISIBLE PART OF A PACKAGE AND A HOMOGRAPHIC SUBPROGRAM IS LATER +-- DECLARED EXPLICITLY IN THE SAME VISIBLE PART. + +-- HISTORY: +-- JRK 09/08/87 CREATED ORIGINAL TEST. + +WITH REPORT; USE REPORT; + +PROCEDURE C34014A IS + + PACKAGE P IS + TYPE T IS RANGE -100 .. 100; + FUNCTION F RETURN T; + END P; + USE P; + + PACKAGE BODY P IS + FUNCTION F RETURN T IS + BEGIN + RETURN T (IDENT_INT (1)); + END F; + END P; + +BEGIN + TEST ("C34014A", "CHECK THAT A DERIVED SUBPROGRAM IS VISIBLE " & + "AND FURTHER DERIVABLE UNDER APPROPRIATE " & + "CIRCUMSTANCES. CHECK WHEN THE DERIVED " & + "SUBPROGRAM IS IMPLICITLY DECLARED IN THE " & + "VISIBLE PART OF A PACKAGE AND A HOMOGRAPHIC " & + "SUBPROGRAM IS LATER DECLARED EXPLICITLY IN " & + "THE SAME VISIBLE PART"); + + ----------------------------------------------------------------- + + COMMENT ("NEW SUBPROGRAM DECLARED BY SUBPROGRAM DECLARATION"); + + DECLARE + + PACKAGE Q IS + TYPE QT IS NEW T; + X : QT := F; + FUNCTION F RETURN QT; + TYPE QR IS + RECORD + C : QT := F; + END RECORD; + PRIVATE + TYPE QS IS NEW QT; + END Q; + USE Q; + + PACKAGE BODY Q IS + FUNCTION F RETURN QT IS + BEGIN + RETURN QT (IDENT_INT (2)); + END F; + + PACKAGE R IS + Y : QR; + Z : QS := F; + END R; + USE R; + BEGIN + IF X /= 1 THEN + FAILED ("OLD SUBPROGRAM NOT VISIBLE - SUBPROG " & + "DECL"); + END IF; + + IF Y.C /= 2 THEN + FAILED ("NEW SUBPROGRAM NOT VISIBLE - SUBPROG " & + "DECL - 1"); + END IF; + + IF Z /= 2 THEN + FAILED ("NEW SUBPROGRAM NOT DERIVED - SUBPROG " & + "DECL - 1"); + END IF; + END Q; + + PACKAGE R IS + Y : QT := F; + TYPE RT IS NEW QT; + Z : RT := F; + END R; + USE R; + + BEGIN + IF Y /= 2 THEN + FAILED ("NEW SUBPROGRAM NOT VISIBLE - SUBPROG DECL - 2"); + END IF; + + IF Z /= 2 THEN + FAILED ("NEW SUBPROGRAM NOT DERIVED - SUBPROG DECL - 2"); + END IF; + END; + + ----------------------------------------------------------------- + + COMMENT ("NEW SUBPROGRAM DECLARED BY RENAMING"); + + DECLARE + + PACKAGE Q IS + TYPE QT IS NEW T; + X : QT := F; + FUNCTION G RETURN QT; + FUNCTION F RETURN QT RENAMES G; + TYPE QR IS + RECORD + C : QT := F; + END RECORD; + PRIVATE + TYPE QS IS NEW QT; + END Q; + USE Q; + + PACKAGE BODY Q IS + FUNCTION G RETURN QT IS + BEGIN + RETURN QT (IDENT_INT (2)); + END G; + + PACKAGE R IS + Y : QR; + Z : QS := F; + END R; + USE R; + BEGIN + IF X /= 1 THEN + FAILED ("OLD SUBPROGRAM NOT VISIBLE - RENAMING"); + END IF; + + IF Y.C /= 2 THEN + FAILED ("NEW SUBPROGRAM NOT VISIBLE - RENAMING - " & + "1"); + END IF; + + IF Z /= 2 THEN + FAILED ("NEW SUBPROGRAM NOT DERIVED - RENAMING - " & + "1"); + END IF; + END Q; + + PACKAGE R IS + Y : QT := F; + TYPE RT IS NEW QT; + Z : RT := F; + END R; + USE R; + + BEGIN + IF Y /= 2 THEN + FAILED ("NEW SUBPROGRAM NOT VISIBLE - RENAMING - 2"); + END IF; + + IF Z /= 2 THEN + FAILED ("NEW SUBPROGRAM NOT DERIVED - RENAMING - 2"); + END IF; + END; + + ----------------------------------------------------------------- + + COMMENT ("NEW SUBPROGRAM DECLARED BY GENERIC INSTANTIATION"); + + DECLARE + + GENERIC + TYPE T IS RANGE <>; + FUNCTION G RETURN T; + + FUNCTION G RETURN T IS + BEGIN + RETURN T (IDENT_INT (2)); + END G; + + PACKAGE Q IS + TYPE QT IS NEW T; + X : QT := F; + FUNCTION F IS NEW G (QT); + W : QT := F; + PRIVATE + TYPE QS IS NEW QT; + Z : QS := F; + END Q; + USE Q; + + PACKAGE BODY Q IS + BEGIN + IF X /= 1 THEN + FAILED ("OLD SUBPROGRAM NOT VISIBLE - " & + "INSTANTIATION"); + END IF; + + IF W /= 2 THEN + FAILED ("NEW SUBPROGRAM NOT VISIBLE - " & + "INSTANTIATION - 1"); + END IF; + + IF Z /= 2 THEN + FAILED ("NEW SUBPROGRAM NOT DERIVED - " & + "INSTANTIATION - 1"); + END IF; + END Q; + + PACKAGE R IS + Y : QT := F; + TYPE RT IS NEW QT; + Z : RT := F; + END R; + USE R; + + BEGIN + IF Y /= 2 THEN + FAILED ("NEW SUBPROGRAM NOT VISIBLE - INSTANTIATION - " & + "2"); + END IF; + + IF Z /= 2 THEN + FAILED ("NEW SUBPROGRAM NOT DERIVED - INSTANTIATION - " & + "2"); + END IF; + END; + + ----------------------------------------------------------------- + + RESULT; +END C34014A; diff --git a/gcc-4.9/gcc/testsuite/ada/acats/tests/c3/c34014c.ada b/gcc-4.9/gcc/testsuite/ada/acats/tests/c3/c34014c.ada new file mode 100644 index 000000000..9dd17e22f --- /dev/null +++ b/gcc-4.9/gcc/testsuite/ada/acats/tests/c3/c34014c.ada @@ -0,0 +1,259 @@ +-- C34014C.ADA + +-- Grant of Unlimited Rights +-- +-- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687, +-- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained +-- unlimited rights in the software and documentation contained herein. +-- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making +-- this public release, the Government intends to confer upon all +-- recipients unlimited rights equal to those held by the Government. +-- These rights include rights to use, duplicate, release or disclose the +-- released technical data and computer software in whole or in part, in +-- any manner and for any purpose whatsoever, and to have or permit others +-- to do so. +-- +-- DISCLAIMER +-- +-- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR +-- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED +-- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF 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 DERIVED SUBPROGRAM IS VISIBLE AND FURTHER DERIVABLE +-- UNDER APPROPRIATE CIRCUMSTANCES. + +-- CHECK WHEN THE DERIVED SUBPROGRAM IS IMPLICITLY DECLARED IN THE +-- VISIBLE PART OF A PACKAGE AND A HOMOGRAPHIC SUBPROGRAM IS LATER +-- DECLARED EXPLICITLY IN THE PRIVATE PART. + +-- HISTORY: +-- JRK 09/11/87 CREATED ORIGINAL TEST. +-- GJD 11/15/95 REMOVED ADA 83 INCOMPATIBILITIES. +-- PWN 10/24/96 RESTORED CHECK WITH NEW ADA 95 RESULTS EXPECTED. +-- PWB.CTA 02/20/97 Made failure messages unique. + +WITH REPORT; USE REPORT; + +PROCEDURE C34014C IS + + PACKAGE P IS + TYPE T IS RANGE -100 .. 100; + FUNCTION F RETURN T; + END P; + USE P; + + PACKAGE BODY P IS + FUNCTION F RETURN T IS + BEGIN + RETURN T (IDENT_INT (1)); + END F; + END P; + +BEGIN + TEST ("C34014C", "CHECK THAT A DERIVED SUBPROGRAM IS VISIBLE " & + "AND FURTHER DERIVABLE UNDER APPROPRIATE " & + "CIRCUMSTANCES. CHECK WHEN THE DERIVED " & + "SUBPROGRAM IS IMPLICITLY DECLARED IN THE " & + "VISIBLE PART OF A PACKAGE AND A HOMOGRAPHIC " & + "SUBPROGRAM IS LATER DECLARED EXPLICITLY IN " & + "THE PRIVATE PART"); + + ----------------------------------------------------------------- + + COMMENT ("NEW SUBPROGRAM DECLARED BY SUBPROGRAM DECLARATION"); + + DECLARE + + PACKAGE Q IS + TYPE QT IS NEW T; + X : QT := F; + PRIVATE + FUNCTION F RETURN QT; + TYPE QR IS + RECORD + C : QT := F; + END RECORD; + TYPE QS IS NEW QT; + END Q; + USE Q; + + PACKAGE BODY Q IS + FUNCTION F RETURN QT IS + BEGIN + RETURN QT (IDENT_INT (2)); + END F; + + PACKAGE R IS + Y : QR; + Z : QS := F; + END R; + USE R; + BEGIN + IF X /= 1 THEN + FAILED ("OLD SUBPROGRAM NOT VISIBLE - SUBPROG " & + "DECL - 1"); + END IF; + + IF Y.C /= 2 THEN + FAILED ("NEW SUBPROGRAM NOT VISIBLE - SUBPROG " & + "DECL"); + END IF; + + IF Z /= 2 THEN + FAILED ("OLD SUBPROGRAM NOT DERIVED - SUBPROG " & + "DECL - 1"); + END IF; + END Q; + + PACKAGE R IS + Y : QT := F; + TYPE RT IS NEW QT; + Z : RT := F; + END R; + USE R; + + BEGIN + IF Y /= 1 THEN + FAILED ("OLD SUBPROGRAM NOT VISIBLE - SUBPROG DECL - 2"); + END IF; + + IF Z /= 1 THEN + FAILED ("OLD SUBPROGRAM NOT DERIVED - SUBPROG DECL - 2"); + END IF; + END; + + ----------------------------------------------------------------- + + COMMENT ("NEW SUBPROGRAM DECLARED BY RENAMING"); + + DECLARE + + PACKAGE Q IS + TYPE QT IS NEW T; + X : QT := F; + PRIVATE + FUNCTION G RETURN QT; + FUNCTION F RETURN QT RENAMES G; + TYPE QR IS + RECORD + C : QT := F; + END RECORD; + TYPE QS IS NEW QT; + END Q; + USE Q; + + PACKAGE BODY Q IS + FUNCTION G RETURN QT IS + BEGIN + RETURN QT (IDENT_INT (2)); + END G; + + PACKAGE R IS + Y : QR; + Z : QS := F; + END R; + USE R; + BEGIN + IF X /= 1 THEN + FAILED ("OLD SUBPROGRAM NOT VISIBLE - RENAMING - " & + "1"); + END IF; + + IF Y.C /= 2 THEN + FAILED ("NEW SUBPROGRAM NOT VISIBLE - RENAMING"); + END IF; + + IF Z /= 2 THEN + FAILED ("OLD SUBPROGRAM NOT DERIVED - RENAMING - " & + "1"); + END IF; + END Q; + + PACKAGE R IS + Y : QT := F; + TYPE RT IS NEW QT; + Z : RT := F; + END R; + USE R; + + BEGIN + IF Y /= 1 THEN + FAILED ("OLD SUBPROGRAM NOT VISIBLE - RENAMING - 2"); + END IF; + + IF Z /= 1 THEN + FAILED ("OLD SUBPROGRAM NOT DERIVED - RENAMING - 2"); + END IF; + END; + + ----------------------------------------------------------------- + + COMMENT ("NEW SUBPROGRAM DECLARED BY GENERIC INSTANTIATION"); + + DECLARE + + GENERIC + TYPE T IS RANGE <>; + FUNCTION G RETURN T; + + FUNCTION G RETURN T IS + BEGIN + RETURN T (IDENT_INT (2)); + END G; + + PACKAGE Q IS + TYPE QT IS NEW T; + X : QT := F; + PRIVATE + FUNCTION F IS NEW G (QT); + W : QT := F; + TYPE QS IS NEW QT; + Z : QS := F; + END Q; + USE Q; + + PACKAGE BODY Q IS + BEGIN + IF X /= 1 THEN + FAILED ("OLD SUBPROGRAM NOT VISIBLE - " & + "INSTANTIATION - 1"); + END IF; + + IF W /= 2 THEN + FAILED ("NEW SUBPROGRAM NOT VISIBLE - " & + "INSTANTIATION"); + END IF; + + IF Z /= 2 THEN + FAILED ("OLD SUBPROGRAM NOT DERIVED - " & + "INSTANTIATION - 1"); + END IF; + END Q; + + PACKAGE R IS + Y : QT := F; + TYPE RT IS NEW QT; + Z : RT := F; + END R; + USE R; + + BEGIN + IF Y /= 1 THEN + FAILED ("OLD SUBPROGRAM NOT VISIBLE - INSTANTIATION - " & + "2"); + END IF; + + IF Z /= 1 THEN + FAILED ("OLD SUBPROGRAM NOT DERIVED - INSTANTIATION - " & + "2"); + END IF; + END; + + ----------------------------------------------------------------- + + RESULT; +END C34014C; diff --git a/gcc-4.9/gcc/testsuite/ada/acats/tests/c3/c34014e.ada b/gcc-4.9/gcc/testsuite/ada/acats/tests/c3/c34014e.ada new file mode 100644 index 000000000..0c7fea237 --- /dev/null +++ b/gcc-4.9/gcc/testsuite/ada/acats/tests/c3/c34014e.ada @@ -0,0 +1,257 @@ +-- C34014E.ADA + +-- Grant of Unlimited Rights +-- +-- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687, +-- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained +-- unlimited rights in the software and documentation contained herein. +-- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making +-- this public release, the Government intends to confer upon all +-- recipients unlimited rights equal to those held by the Government. +-- These rights include rights to use, duplicate, release or disclose the +-- released technical data and computer software in whole or in part, in +-- any manner and for any purpose whatsoever, and to have or permit others +-- to do so. +-- +-- DISCLAIMER +-- +-- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR +-- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED +-- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF 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 DERIVED SUBPROGRAM IS VISIBLE AND FURTHER DERIVABLE +-- UNDER APPROPRIATE CIRCUMSTANCES. + +-- CHECK WHEN THE DERIVED SUBPROGRAM IS IMPLICITLY DECLARED IN THE +-- VISIBLE PART OF A PACKAGE AND A HOMOGRAPHIC SUBPROGRAM IS LATER +-- DECLARED EXPLICITLY IN THE PACKAGE BODY. + +-- HISTORY: +-- JRK 09/15/87 CREATED ORIGINAL TEST. +-- GJD 11/15/95 REMOVED ADA 83 INCOMPATIBILITIES. +-- PWN 04/11/96 Restored subtests in Ada95 legal format. + +WITH REPORT; USE REPORT; + +PROCEDURE C34014E IS + + PACKAGE P IS + TYPE T IS RANGE -100 .. 100; + FUNCTION F RETURN T; + END P; + USE P; + + PACKAGE BODY P IS + FUNCTION F RETURN T IS + BEGIN + RETURN T (IDENT_INT (1)); + END F; + END P; + +BEGIN + TEST ("C34014E", "CHECK THAT A DERIVED SUBPROGRAM IS VISIBLE " & + "AND FURTHER DERIVABLE UNDER APPROPRIATE " & + "CIRCUMSTANCES. CHECK WHEN THE DERIVED " & + "SUBPROGRAM IS IMPLICITLY DECLARED IN THE " & + "VISIBLE PART OF A PACKAGE AND A HOMOGRAPHIC " & + "SUBPROGRAM IS LATER DECLARED EXPLICITLY IN " & + "THE PACKAGE BODY"); + + ----------------------------------------------------------------- + + COMMENT ("NEW SUBPROGRAM DECLARED BY SUBPROGRAM DECLARATION"); + + DECLARE + + PACKAGE Q IS + TYPE QT IS NEW T; + X : QT := F; + END Q; + USE Q; + + PACKAGE BODY Q IS + FUNCTION F RETURN QT; + TYPE QR IS + RECORD + C : QT := F; + END RECORD; + TYPE QS IS NEW QT; + + FUNCTION F RETURN QT IS + BEGIN + RETURN QT (IDENT_INT (2)); + END F; + + PACKAGE R IS + Y : QR; + Z : QS := F; + END R; + USE R; + BEGIN + IF X /= 1 THEN + FAILED ("OLD SUBPROGRAM NOT VISIBLE - SUBPROG " & + "DECL - 1"); + END IF; + + IF Y.C /= 2 THEN + FAILED ("NEW SUBPROGRAM NOT VISIBLE - SUBPROG " & + "DECL"); + END IF; + + IF Z /= 2 THEN + FAILED ("OLD SUBPROGRAM NOT DERIVED - SUBPROG " & + "DECL - 1"); + END IF; + END Q; + + PACKAGE R IS + Y : QT := F; + TYPE RT IS NEW QT; + Z : RT := F; + END R; + USE R; + + BEGIN + IF Y /= 1 THEN + FAILED ("OLD SUBPROGRAM NOT VISIBLE - SUBPROG DECL - 2"); + END IF; + + IF Z /= 1 THEN + FAILED ("OLD SUBPROGRAM NOT DERIVED - SUBPROG DECL - 2"); + END IF; + END; + + ----------------------------------------------------------------- + + COMMENT ("NEW SUBPROGRAM DECLARED BY RENAMING"); + + DECLARE + + PACKAGE Q IS + TYPE QT IS NEW T; + X : QT := F; + END Q; + USE Q; + + PACKAGE BODY Q IS + FUNCTION G RETURN QT; + FUNCTION F RETURN QT RENAMES G; + TYPE QR IS + RECORD + C : QT := F; + END RECORD; + TYPE QS IS NEW QT; + + FUNCTION G RETURN QT IS + BEGIN + RETURN QT (IDENT_INT (2)); + END G; + + PACKAGE R IS + Y : QR; + Z : QS := F; + END R; + USE R; + BEGIN + IF X /= 1 THEN + FAILED ("OLD SUBPROGRAM NOT VISIBLE - RENAMING - " & + "1"); + END IF; + + IF Y.C /= 2 THEN + FAILED ("NEW SUBPROGRAM NOT VISIBLE - RENAMING"); + END IF; + + IF Z /= 2 THEN + FAILED ("OLD SUBPROGRAM NOT DERIVED - RENAMING - " & + "1"); + END IF; + END Q; + + PACKAGE R IS + Y : QT := F; + TYPE RT IS NEW QT; + Z : RT := F; + END R; + USE R; + + BEGIN + IF Y /= 1 THEN + FAILED ("OLD SUBPROGRAM NOT VISIBLE - RENAMING - 2"); + END IF; + + IF Z /= 1 THEN + FAILED ("OLD SUBPROGRAM NOT DERIVED - RENAMING - 2"); + END IF; + END; + + ----------------------------------------------------------------- + + COMMENT ("NEW SUBPROGRAM DECLARED BY GENERIC INSTANTIATION"); + + DECLARE + + GENERIC + TYPE T IS RANGE <>; + FUNCTION G RETURN T; + + FUNCTION G RETURN T IS + BEGIN + RETURN T (IDENT_INT (2)); + END G; + + PACKAGE Q IS + TYPE QT IS NEW T; + X : QT := F; + END Q; + USE Q; + + PACKAGE BODY Q IS + FUNCTION F IS NEW G (QT); + W : QT := F; + TYPE QS IS NEW QT; + Z : QS := F; + BEGIN + IF X /= 1 THEN + FAILED ("OLD SUBPROGRAM NOT VISIBLE - " & + "INSTANTIATION - 1"); + END IF; + + IF W /= 2 THEN + FAILED ("NEW SUBPROGRAM NOT VISIBLE - " & + "INSTANTIATION"); + END IF; + + IF Z /= 2 THEN + FAILED ("OLD SUBPROGRAM NOT DERIVED - " & + "INSTANTIATION - 1"); + END IF; + END Q; + + PACKAGE R IS + Y : QT := F; + TYPE RT IS NEW QT; + Z : RT := F; + END R; + USE R; + + BEGIN + IF Y /= 1 THEN + FAILED ("OLD SUBPROGRAM NOT VISIBLE - INSTANTIATION - " & + "2"); + END IF; + + IF Z /= 1 THEN + FAILED ("OLD SUBPROGRAM NOT DERIVED - INSTANTIATION - " & + "2"); + END IF; + END; + + ----------------------------------------------------------------- + + RESULT; +END C34014E; diff --git a/gcc-4.9/gcc/testsuite/ada/acats/tests/c3/c34014g.ada b/gcc-4.9/gcc/testsuite/ada/acats/tests/c3/c34014g.ada new file mode 100644 index 000000000..5be7f5008 --- /dev/null +++ b/gcc-4.9/gcc/testsuite/ada/acats/tests/c3/c34014g.ada @@ -0,0 +1,107 @@ +-- C34014G.ADA + +-- Grant of Unlimited Rights +-- +-- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687, +-- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained +-- unlimited rights in the software and documentation contained herein. +-- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making +-- this public release, the Government intends to confer upon all +-- recipients unlimited rights equal to those held by the Government. +-- These rights include rights to use, duplicate, release or disclose the +-- released technical data and computer software in whole or in part, in +-- any manner and for any purpose whatsoever, and to have or permit others +-- to do so. +-- +-- DISCLAIMER +-- +-- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR +-- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED +-- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF 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 DERIVED SUBPROGRAM IS VISIBLE AND FURTHER DERIVABLE +-- UNDER APPROPRIATE CIRCUMSTANCES. + +-- CHECK WHEN THE DERIVED SUBPROGRAM IS IMPLICITLY DECLARED IN THE +-- VISIBLE PART OF A PACKAGE AND NO HOMOGRAPHIC SUBPROGRAM IS LATER +-- DECLARED EXPLICITLY. + +-- HISTORY: +-- JRK 09/16/87 CREATED ORIGINAL TEST. + +WITH REPORT; USE REPORT; + +PROCEDURE C34014G IS + + PACKAGE P IS + TYPE T IS RANGE -100 .. 100; + FUNCTION F RETURN T; + END P; + USE P; + + PACKAGE BODY P IS + FUNCTION F RETURN T IS + BEGIN + RETURN T (IDENT_INT (1)); + END F; + END P; + +BEGIN + TEST ("C34014G", "CHECK THAT A DERIVED SUBPROGRAM IS VISIBLE " & + "AND FURTHER DERIVABLE UNDER APPROPRIATE " & + "CIRCUMSTANCES. CHECK WHEN THE DERIVED " & + "SUBPROGRAM IS IMPLICITLY DECLARED IN THE " & + "VISIBLE PART OF A PACKAGE AND NO HOMOGRAPHIC " & + "SUBPROGRAM IS LATER DECLARED EXPLICITLY"); + + ----------------------------------------------------------------- + + COMMENT ("NO NEW SUBPROGRAM DECLARED EXPLICITLY"); + + DECLARE + + PACKAGE Q IS + TYPE QT IS NEW T; + X : QT := F; + PRIVATE + TYPE QS IS NEW QT; + Z : QS := F; + END Q; + USE Q; + + PACKAGE BODY Q IS + BEGIN + IF X /= 1 THEN + FAILED ("OLD SUBPROGRAM NOT VISIBLE - 1"); + END IF; + + IF Z /= 1 THEN + FAILED ("OLD SUBPROGRAM NOT DERIVED - 1"); + END IF; + END Q; + + PACKAGE R IS + Y : QT := F; + TYPE RT IS NEW QT; + Z : RT := F; + END R; + USE R; + + BEGIN + IF Y /= 1 THEN + FAILED ("OLD SUBPROGRAM NOT VISIBLE - 2"); + END IF; + + IF Z /= 1 THEN + FAILED ("OLD SUBPROGRAM NOT DERIVED - 2"); + END IF; + END; + + ----------------------------------------------------------------- + + RESULT; +END C34014G; diff --git a/gcc-4.9/gcc/testsuite/ada/acats/tests/c3/c34014h.ada b/gcc-4.9/gcc/testsuite/ada/acats/tests/c3/c34014h.ada new file mode 100644 index 000000000..b1bf56c31 --- /dev/null +++ b/gcc-4.9/gcc/testsuite/ada/acats/tests/c3/c34014h.ada @@ -0,0 +1,208 @@ +-- C34014H.ADA + +-- Grant of Unlimited Rights +-- +-- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687, +-- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained +-- unlimited rights in the software and documentation contained herein. +-- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making +-- this public release, the Government intends to confer upon all +-- recipients unlimited rights equal to those held by the Government. +-- These rights include rights to use, duplicate, release or disclose the +-- released technical data and computer software in whole or in part, in +-- any manner and for any purpose whatsoever, and to have or permit others +-- to do so. +-- +-- DISCLAIMER +-- +-- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR +-- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED +-- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF 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 DERIVED SUBPROGRAM IS VISIBLE AND FURTHER DERIVABLE +-- UNDER APPROPRIATE CIRCUMSTANCES. + +-- CHECK WHEN THE DERIVED SUBPROGRAM IS IMPLICITLY DECLARED IN THE +-- PRIVATE PART OF A PACKAGE AFTER AN EXPLICIT DECLARATION OF A +-- HOMOGRAPHIC SUBPROGRAM IN THE VISIBLE PART. + +-- HISTORY: +-- JRK 09/16/87 CREATED ORIGINAL TEST. + +WITH REPORT; USE REPORT; + +PROCEDURE C34014H IS + + PACKAGE P IS + TYPE T IS RANGE -100 .. 100; + FUNCTION F RETURN T; + END P; + USE P; + + PACKAGE BODY P IS + FUNCTION F RETURN T IS + BEGIN + RETURN T (IDENT_INT (1)); + END F; + END P; + +BEGIN + TEST ("C34014H", "CHECK THAT A DERIVED SUBPROGRAM IS VISIBLE " & + "AND FURTHER DERIVABLE UNDER APPROPRIATE " & + "CIRCUMSTANCES. CHECK WHEN THE DERIVED " & + "SUBPROGRAM IS IMPLICITLY DECLARED IN THE " & + "PRIVATE PART OF A PACKAGE AFTER AN EXPLICIT " & + "DECLARATION OF A HOMOGRAPHIC SUBPROGRAM IN " & + "THE VISIBLE PART"); + + ----------------------------------------------------------------- + + COMMENT ("NEW SUBPROGRAM DECLARED BY SUBPROGRAM DECLARATION"); + + DECLARE + + PACKAGE Q IS + TYPE QT IS PRIVATE; + C2 : CONSTANT QT; + FUNCTION F RETURN QT; + TYPE QR1 IS + RECORD + C : QT := F; + END RECORD; + PRIVATE + TYPE QT IS NEW T; + C2 : CONSTANT QT := 2; + TYPE QR2 IS + RECORD + C : QT := F; + END RECORD; + TYPE QS IS NEW QT; + END Q; + USE Q; + + PACKAGE BODY Q IS + FUNCTION F RETURN QT IS + BEGIN + RETURN QT (IDENT_INT (2)); + END F; + + PACKAGE R IS + X : QR1; + Y : QR2; + Z : QS := F; + END R; + USE R; + BEGIN + IF X.C /= 2 THEN + FAILED ("NEW SUBPROGRAM NOT VISIBLE - SUBPROG " & + "DECL - 1"); + END IF; + + IF Y.C /= 2 THEN + FAILED ("NEW SUBPROGRAM NOT VISIBLE - SUBPROG " & + "DECL - 2"); + END IF; + + IF Z /= 2 THEN + FAILED ("NEW SUBPROGRAM NOT DERIVED - SUBPROG " & + "DECL - 1"); + END IF; + END Q; + + PACKAGE R IS + Y : QT := F; + TYPE RT IS NEW QT; + Z : RT := F; + END R; + USE R; + + BEGIN + IF Y /= C2 THEN + FAILED ("NEW SUBPROGRAM NOT VISIBLE - SUBPROG DECL - 3"); + END IF; + + IF Z /= RT (C2) THEN + FAILED ("NEW SUBPROGRAM NOT DERIVED - SUBPROG DECL - 2"); + END IF; + END; + + ----------------------------------------------------------------- + + COMMENT ("NEW SUBPROGRAM DECLARED BY RENAMING"); + + DECLARE + + PACKAGE Q IS + TYPE QT IS PRIVATE; + C2 : CONSTANT QT; + FUNCTION G RETURN QT; + FUNCTION F RETURN QT RENAMES G; + TYPE QR1 IS + RECORD + C : QT := F; + END RECORD; + PRIVATE + TYPE QT IS NEW T; + C2 : CONSTANT QT := 2; + TYPE QR2 IS + RECORD + C : QT := F; + END RECORD; + TYPE QS IS NEW QT; + END Q; + USE Q; + + PACKAGE BODY Q IS + FUNCTION G RETURN QT IS + BEGIN + RETURN QT (IDENT_INT (2)); + END G; + + PACKAGE R IS + X : QR1; + Y : QR2; + Z : QS := F; + END R; + USE R; + BEGIN + IF X.C /= 2 THEN + FAILED ("NEW SUBPROGRAM NOT VISIBLE - RENAMING - " & + "1"); + END IF; + + IF Y.C /= 2 THEN + FAILED ("NEW SUBPROGRAM NOT VISIBLE - RENAMING - " & + "2"); + END IF; + + IF Z /= 2 THEN + FAILED ("NEW SUBPROGRAM NOT DERIVED - RENAMING - " & + "1"); + END IF; + END Q; + + PACKAGE R IS + Y : QT := F; + TYPE RT IS NEW QT; + Z : RT := F; + END R; + USE R; + + BEGIN + IF Y /= C2 THEN + FAILED ("NEW SUBPROGRAM NOT VISIBLE - RENAMING - 3"); + END IF; + + IF Z /= RT (C2) THEN + FAILED ("NEW SUBPROGRAM NOT DERIVED - RENAMING - 2"); + END IF; + END; + + ----------------------------------------------------------------- + + RESULT; +END C34014H; diff --git a/gcc-4.9/gcc/testsuite/ada/acats/tests/c3/c34014n.ada b/gcc-4.9/gcc/testsuite/ada/acats/tests/c3/c34014n.ada new file mode 100644 index 000000000..321a784e5 --- /dev/null +++ b/gcc-4.9/gcc/testsuite/ada/acats/tests/c3/c34014n.ada @@ -0,0 +1,256 @@ +-- C34014N.ADA + +-- Grant of Unlimited Rights +-- +-- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687, +-- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained +-- unlimited rights in the software and documentation contained herein. +-- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making +-- this public release, the Government intends to confer upon all +-- recipients unlimited rights equal to those held by the Government. +-- These rights include rights to use, duplicate, release or disclose the +-- released technical data and computer software in whole or in part, in +-- any manner and for any purpose whatsoever, and to have or permit others +-- to do so. +-- +-- DISCLAIMER +-- +-- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR +-- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED +-- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF 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 DERIVED OPERATOR IS VISIBLE AND FURTHER DERIVABLE +-- UNDER APPROPRIATE CIRCUMSTANCES. + +-- CHECK WHEN THE DERIVED OPERATOR IS IMPLICITLY DECLARED IN THE +-- VISIBLE PART OF A PACKAGE AND A HOMOGRAPHIC OPERATOR IS LATER +-- DECLARED EXPLICITLY IN THE SAME VISIBLE PART. + +-- HISTORY: +-- JRK 09/21/87 CREATED ORIGINAL TEST. + +WITH REPORT; USE REPORT; + +PROCEDURE C34014N IS + + PACKAGE P IS + TYPE T IS RANGE -100 .. 100; + FUNCTION "+" (X : T) RETURN T; + END P; + USE P; + + PACKAGE BODY P IS + FUNCTION "+" (X : T) RETURN T IS + BEGIN + RETURN X + T (IDENT_INT (1)); + END "+"; + END P; + +BEGIN + TEST ("C34014N", "CHECK THAT A DERIVED OPERATOR IS VISIBLE " & + "AND FURTHER DERIVABLE UNDER APPROPRIATE " & + "CIRCUMSTANCES. CHECK WHEN THE DERIVED " & + "OPERATOR IS IMPLICITLY DECLARED IN THE " & + "VISIBLE PART OF A PACKAGE AND A HOMOGRAPHIC " & + "OPERATOR IS LATER DECLARED EXPLICITLY IN " & + "THE SAME VISIBLE PART"); + + ----------------------------------------------------------------- + + COMMENT ("NEW OPERATOR DECLARED BY SUBPROGRAM DECLARATION"); + + DECLARE + + PACKAGE Q IS + TYPE QT IS NEW T; + X : QT := +0; + FUNCTION "+" (Y : QT) RETURN QT; + TYPE QR IS + RECORD + C : QT := +0; + END RECORD; + PRIVATE + TYPE QS IS NEW QT; + END Q; + USE Q; + + PACKAGE BODY Q IS + FUNCTION "+" (Y : QT) RETURN QT IS + BEGIN + RETURN Y + QT (IDENT_INT (2)); + END "+"; + + PACKAGE R IS + Y : QR; + Z : QS := +0; + END R; + USE R; + BEGIN + IF X /= 1 THEN + FAILED ("OLD OPERATOR NOT VISIBLE - SUBPROG " & + "DECL"); + END IF; + + IF Y.C /= 2 THEN + FAILED ("NEW OPERATOR NOT VISIBLE - SUBPROG " & + "DECL - 1"); + END IF; + + IF Z /= 2 THEN + FAILED ("NEW OPERATOR NOT DERIVED - SUBPROG " & + "DECL - 1"); + END IF; + END Q; + + PACKAGE R IS + Y : QT := +0; + TYPE RT IS NEW QT; + Z : RT := +0; + END R; + USE R; + + BEGIN + IF Y /= 2 THEN + FAILED ("NEW OPERATOR NOT VISIBLE - SUBPROG DECL - 2"); + END IF; + + IF Z /= 2 THEN + FAILED ("NEW OPERATOR NOT DERIVED - SUBPROG DECL - 2"); + END IF; + END; + + ----------------------------------------------------------------- + + COMMENT ("NEW OPERATOR DECLARED BY RENAMING"); + + DECLARE + + PACKAGE Q IS + TYPE QT IS NEW T; + X : QT := +0; + FUNCTION G (X : QT) RETURN QT; + FUNCTION "+" (Y : QT) RETURN QT RENAMES G; + TYPE QR IS + RECORD + C : QT := +0; + END RECORD; + PRIVATE + TYPE QS IS NEW QT; + END Q; + USE Q; + + PACKAGE BODY Q IS + FUNCTION G (X : QT) RETURN QT IS + BEGIN + RETURN X + QT (IDENT_INT (2)); + END G; + + PACKAGE R IS + Y : QR; + Z : QS := +0; + END R; + USE R; + BEGIN + IF X /= 1 THEN + FAILED ("OLD OPERATOR NOT VISIBLE - RENAMING"); + END IF; + + IF Y.C /= 2 THEN + FAILED ("NEW OPERATOR NOT VISIBLE - RENAMING - " & + "1"); + END IF; + + IF Z /= 2 THEN + FAILED ("NEW OPERATOR NOT DERIVED - RENAMING - " & + "1"); + END IF; + END Q; + + PACKAGE R IS + Y : QT := +0; + TYPE RT IS NEW QT; + Z : RT := +0; + END R; + USE R; + + BEGIN + IF Y /= 2 THEN + FAILED ("NEW OPERATOR NOT VISIBLE - RENAMING - 2"); + END IF; + + IF Z /= 2 THEN + FAILED ("NEW OPERATOR NOT DERIVED - RENAMING - 2"); + END IF; + END; + + ----------------------------------------------------------------- + + COMMENT ("NEW OPERATOR DECLARED BY GENERIC INSTANTIATION"); + + DECLARE + + GENERIC + TYPE T IS RANGE <>; + FUNCTION G (Y : T) RETURN T; + + FUNCTION G (Y : T) RETURN T IS + BEGIN + RETURN Y + T (IDENT_INT (2)); + END G; + + PACKAGE Q IS + TYPE QT IS NEW T; + X : QT := +0; + FUNCTION "+" IS NEW G (QT); + W : QT := +0; + PRIVATE + TYPE QS IS NEW QT; + Z : QS := +0; + END Q; + USE Q; + + PACKAGE BODY Q IS + BEGIN + IF X /= 1 THEN + FAILED ("OLD OPERATOR NOT VISIBLE - " & + "INSTANTIATION"); + END IF; + + IF W /= 2 THEN + FAILED ("NEW OPERATOR NOT VISIBLE - " & + "INSTANTIATION - 1"); + END IF; + + IF Z /= 2 THEN + FAILED ("NEW OPERATOR NOT DERIVED - " & + "INSTANTIATION - 1"); + END IF; + END Q; + + PACKAGE R IS + Y : QT := +0; + TYPE RT IS NEW QT; + Z : RT := +0; + END R; + USE R; + + BEGIN + IF Y /= 2 THEN + FAILED ("NEW OPERATOR NOT VISIBLE - INSTANTIATION - " & + "2"); + END IF; + + IF Z /= 2 THEN + FAILED ("NEW OPERATOR NOT DERIVED - INSTANTIATION - " & + "2"); + END IF; + END; + + ----------------------------------------------------------------- + + RESULT; +END C34014N; diff --git a/gcc-4.9/gcc/testsuite/ada/acats/tests/c3/c34014p.ada b/gcc-4.9/gcc/testsuite/ada/acats/tests/c3/c34014p.ada new file mode 100644 index 000000000..161fbbbff --- /dev/null +++ b/gcc-4.9/gcc/testsuite/ada/acats/tests/c3/c34014p.ada @@ -0,0 +1,258 @@ +-- C34014P.ADA + +-- Grant of Unlimited Rights +-- +-- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687, +-- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained +-- unlimited rights in the software and documentation contained herein. +-- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making +-- this public release, the Government intends to confer upon all +-- recipients unlimited rights equal to those held by the Government. +-- These rights include rights to use, duplicate, release or disclose the +-- released technical data and computer software in whole or in part, in +-- any manner and for any purpose whatsoever, and to have or permit others +-- to do so. +-- +-- DISCLAIMER +-- +-- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR +-- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED +-- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF 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 DERIVED OPERATOR IS VISIBLE AND FURTHER DERIVABLE +-- UNDER APPROPRIATE CIRCUMSTANCES. + +-- CHECK WHEN THE DERIVED OPERATOR IS IMPLICITLY DECLARED IN THE +-- VISIBLE PART OF A PACKAGE AND A HOMOGRAPHIC OPERATOR IS LATER +-- DECLARED EXPLICITLY IN THE PRIVATE PART. + +-- HISTORY: +-- JRK 09/22/87 CREATED ORIGINAL TEST. +-- GJD 11/15/95 REMOVED ADA 83 INCOMPATIBILITIES. +-- PWN 04/11/96 Restored subtests in Ada95 legal format. + +WITH REPORT; USE REPORT; + +PROCEDURE C34014P IS + + PACKAGE P IS + TYPE T IS RANGE -100 .. 100; + FUNCTION "+" (X : T) RETURN T; + END P; + USE P; + + PACKAGE BODY P IS + FUNCTION "+" (X : T) RETURN T IS + BEGIN + RETURN X + T (IDENT_INT (1)); + END "+"; + END P; + +BEGIN + TEST ("C34014P", "CHECK THAT A DERIVED OPERATOR IS VISIBLE " & + "AND FURTHER DERIVABLE UNDER APPROPRIATE " & + "CIRCUMSTANCES. CHECK WHEN THE DERIVED " & + "OPERATOR IS IMPLICITLY DECLARED IN THE " & + "VISIBLE PART OF A PACKAGE AND A HOMOGRAPHIC " & + "OPERATOR IS LATER DECLARED EXPLICITLY IN " & + "THE PRIVATE PART"); + + ----------------------------------------------------------------- + + COMMENT ("NEW OPERATOR DECLARED BY SUBPROGRAM DECLARATION"); + + DECLARE + + PACKAGE Q IS + TYPE QT IS NEW T; + X : QT := +0; + PRIVATE + FUNCTION "+" (Y : QT) RETURN QT; + TYPE QR IS + RECORD + C : QT := +0; + END RECORD; + TYPE QS IS NEW QT; + END Q; + USE Q; + + PACKAGE BODY Q IS + FUNCTION "+" (Y : QT) RETURN QT IS + BEGIN + RETURN Y + QT (IDENT_INT (2)); + END "+"; + + PACKAGE R IS + Y : QR; + Z : QS := +0; + END R; + USE R; + BEGIN + IF X /= 1 THEN + FAILED ("OLD OPERATOR NOT VISIBLE - SUBPROG " & + "DECL - 1"); + END IF; + + IF Y.C /= 2 THEN + FAILED ("NEW OPERATOR NOT VISIBLE - SUBPROG " & + "DECL"); + END IF; + + IF Z /= 2 THEN + FAILED ("OLD OPERATOR NOT DERIVED - SUBPROG " & + "DECL - 1"); + END IF; + END Q; + + PACKAGE R IS + Y : QT := +0; + TYPE RT IS NEW QT; + Z : RT := +0; + END R; + USE R; + + BEGIN + IF Y /= 1 THEN + FAILED ("OLD OPERATOR NOT VISIBLE - SUBPROG DECL - 2"); + END IF; + + IF Z /= 1 THEN + FAILED ("OLD OPERATOR NOT DERIVED - SUBPROG DECL - 2"); + END IF; + END; + + ----------------------------------------------------------------- + + COMMENT ("NEW OPERATOR DECLARED BY RENAMING"); + + DECLARE + + PACKAGE Q IS + TYPE QT IS NEW T; + X : QT := +0; + PRIVATE + FUNCTION G (X : QT) RETURN QT; + FUNCTION "+" (Y : QT) RETURN QT RENAMES G; + TYPE QR IS + RECORD + C : QT := +0; + END RECORD; + TYPE QS IS NEW QT; + END Q; + USE Q; + + PACKAGE BODY Q IS + FUNCTION G (X : QT) RETURN QT IS + BEGIN + RETURN X + QT (IDENT_INT (2)); + END G; + + PACKAGE R IS + Y : QR; + Z : QS := +0; + END R; + USE R; + BEGIN + IF X /= 1 THEN + FAILED ("OLD OPERATOR NOT VISIBLE - RENAMING - " & + "1"); + END IF; + + IF Y.C /= 2 THEN + FAILED ("NEW OPERATOR NOT VISIBLE - RENAMING"); + END IF; + + IF Z /= 2 THEN + FAILED ("OLD OPERATOR NOT DERIVED - RENAMING - " & + "1"); + END IF; + END Q; + + PACKAGE R IS + Y : QT := +0; + TYPE RT IS NEW QT; + Z : RT := +0; + END R; + USE R; + + BEGIN + IF Y /= 1 THEN + FAILED ("OLD OPERATOR NOT VISIBLE - RENAMING - 2"); + END IF; + + IF Z /= 1 THEN + FAILED ("OLD OPERATOR NOT DERIVED - RENAMING - 2"); + END IF; + END; + + ----------------------------------------------------------------- + + COMMENT ("NEW OPERATOR DECLARED BY GENERIC INSTANTIATION"); + + DECLARE + + GENERIC + TYPE T IS RANGE <>; + FUNCTION G (Y : T) RETURN T; + + FUNCTION G (Y : T) RETURN T IS + BEGIN + RETURN Y + T (IDENT_INT (2)); + END G; + + PACKAGE Q IS + TYPE QT IS NEW T; + X : QT := +0; + PRIVATE + FUNCTION "+" IS NEW G (QT); + W : QT := +0; + TYPE QS IS NEW QT; + Z : QS := +0; + END Q; + USE Q; + + PACKAGE BODY Q IS + BEGIN + IF X /= 1 THEN + FAILED ("OLD OPERATOR NOT VISIBLE - " & + "INSTANTIATION - 1"); + END IF; + + IF W /= 2 THEN + FAILED ("NEW OPERATOR NOT VISIBLE - " & + "INSTANTIATION"); + END IF; + + IF Z /= 2 THEN + FAILED ("OLD OPERATOR NOT DERIVED - " & + "INSTANTIATION - 1"); + END IF; + END Q; + + PACKAGE R IS + Y : QT := +0; + TYPE RT IS NEW QT; + Z : RT := +0; + END R; + USE R; + + BEGIN + IF Y /= 1 THEN + FAILED ("OLD OPERATOR NOT VISIBLE - INSTANTIATION - " & + "2"); + END IF; + + IF Z /= 1 THEN + FAILED ("OLD OPERATOR NOT DERIVED - INSTANTIATION - " & + "2"); + END IF; + END; + + ----------------------------------------------------------------- + + RESULT; +END C34014P; diff --git a/gcc-4.9/gcc/testsuite/ada/acats/tests/c3/c34014r.ada b/gcc-4.9/gcc/testsuite/ada/acats/tests/c3/c34014r.ada new file mode 100644 index 000000000..ab21b4842 --- /dev/null +++ b/gcc-4.9/gcc/testsuite/ada/acats/tests/c3/c34014r.ada @@ -0,0 +1,257 @@ +-- C34014R.ADA + +-- Grant of Unlimited Rights +-- +-- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687, +-- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained +-- unlimited rights in the software and documentation contained herein. +-- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making +-- this public release, the Government intends to confer upon all +-- recipients unlimited rights equal to those held by the Government. +-- These rights include rights to use, duplicate, release or disclose the +-- released technical data and computer software in whole or in part, in +-- any manner and for any purpose whatsoever, and to have or permit others +-- to do so. +-- +-- DISCLAIMER +-- +-- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR +-- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED +-- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF 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 DERIVED OPERATOR IS VISIBLE AND FURTHER DERIVABLE +-- UNDER APPROPRIATE CIRCUMSTANCES. + +-- CHECK WHEN THE DERIVED OPERATOR IS IMPLICITLY DECLARED IN THE +-- VISIBLE PART OF A PACKAGE AND A HOMOGRAPHIC OPERATOR IS LATER +-- DECLARED EXPLICITLY IN THE PACKAGE BODY. + +-- HISTORY: +-- JRK 09/22/87 CREATED ORIGINAL TEST. +-- GJD 11/15/95 REMOVED ADA 83 INCOMPATIBILITIES. +-- PWN 04/11/96 Restored subtests in Ada95 legal format. + +WITH REPORT; USE REPORT; + +PROCEDURE C34014R IS + + PACKAGE P IS + TYPE T IS RANGE -100 .. 100; + FUNCTION "+" (X : T) RETURN T; + END P; + USE P; + + PACKAGE BODY P IS + FUNCTION "+" (X : T) RETURN T IS + BEGIN + RETURN X + T (IDENT_INT (1)); + END "+"; + END P; + +BEGIN + TEST ("C34014R", "CHECK THAT A DERIVED OPERATOR IS VISIBLE " & + "AND FURTHER DERIVABLE UNDER APPROPRIATE " & + "CIRCUMSTANCES. CHECK WHEN THE DERIVED " & + "OPERATOR IS IMPLICITLY DECLARED IN THE " & + "VISIBLE PART OF A PACKAGE AND A HOMOGRAPHIC " & + "OPERATOR IS LATER DECLARED EXPLICITLY IN " & + "THE PACKAGE BODY"); + + ----------------------------------------------------------------- + + COMMENT ("NEW OPERATOR DECLARED BY SUBPROGRAM DECLARATION"); + + DECLARE + + PACKAGE Q IS + TYPE QT IS NEW T; + X : QT := +0; + END Q; + USE Q; + + PACKAGE BODY Q IS + FUNCTION "+" (Y : QT) RETURN QT; + TYPE QR IS + RECORD + C : QT := +0; + END RECORD; + TYPE QS IS NEW QT; + + FUNCTION "+" (Y : QT) RETURN QT IS + BEGIN + RETURN Y + QT (IDENT_INT (2)); + END "+"; + + PACKAGE R IS + Y : QR; + Z : QS := +0; + END R; + USE R; + BEGIN + IF X /= 1 THEN + FAILED ("OLD OPERATOR NOT VISIBLE - SUBPROG " & + "DECL - 1"); + END IF; + + IF Y.C /= 2 THEN + FAILED ("NEW OPERATOR NOT VISIBLE - SUBPROG " & + "DECL"); + END IF; + + IF Z /= 2 THEN + FAILED ("OLD OPERATOR NOT DERIVED - SUBPROG " & + "DECL - 1"); + END IF; + END Q; + + PACKAGE R IS + Y : QT := +0; + TYPE RT IS NEW QT; + Z : RT := +0; + END R; + USE R; + + BEGIN + IF Y /= 1 THEN + FAILED ("OLD OPERATOR NOT VISIBLE - SUBPROG DECL - 2"); + END IF; + + IF Z /= 1 THEN + FAILED ("OLD OPERATOR NOT DERIVED - SUBPROG DECL - 2"); + END IF; + END; + + ----------------------------------------------------------------- + + COMMENT ("NEW OPERATOR DECLARED BY RENAMING"); + + DECLARE + + PACKAGE Q IS + TYPE QT IS NEW T; + X : QT := +0; + END Q; + USE Q; + + PACKAGE BODY Q IS + FUNCTION G (X : QT) RETURN QT; + FUNCTION "+" (Y : QT) RETURN QT RENAMES G; + TYPE QR IS + RECORD + C : QT := +0; + END RECORD; + TYPE QS IS NEW QT; + + FUNCTION G (X : QT) RETURN QT IS + BEGIN + RETURN X + QT (IDENT_INT (2)); + END G; + + PACKAGE R IS + Y : QR; + Z : QS := +0; + END R; + USE R; + BEGIN + IF X /= 1 THEN + FAILED ("OLD OPERATOR NOT VISIBLE - RENAMING - " & + "1"); + END IF; + + IF Y.C /= 2 THEN + FAILED ("NEW OPERATOR NOT VISIBLE - RENAMING"); + END IF; + + IF Z /= 2 THEN + FAILED ("OLD OPERATOR NOT DERIVED - RENAMING - " & + "1"); + END IF; + END Q; + + PACKAGE R IS + Y : QT := +0; + TYPE RT IS NEW QT; + Z : RT := +0; + END R; + USE R; + + BEGIN + IF Y /= 1 THEN + FAILED ("OLD OPERATOR NOT VISIBLE - RENAMING - 2"); + END IF; + + IF Z /= 1 THEN + FAILED ("OLD OPERATOR NOT DERIVED - RENAMING - 2"); + END IF; + END; + + ----------------------------------------------------------------- + + COMMENT ("NEW OPERATOR DECLARED BY GENERIC INSTANTIATION"); + + DECLARE + + GENERIC + TYPE T IS RANGE <>; + FUNCTION G (Y : T) RETURN T; + + FUNCTION G (Y : T) RETURN T IS + BEGIN + RETURN Y + T (IDENT_INT (2)); + END G; + + PACKAGE Q IS + TYPE QT IS NEW T; + X : QT := +0; + END Q; + USE Q; + + PACKAGE BODY Q IS + FUNCTION "+" IS NEW G (QT); + W : QT := +0; + TYPE QS IS NEW QT; + Z : QS := +0; + BEGIN + IF X /= 1 THEN + FAILED ("OLD OPERATOR NOT VISIBLE - " & + "INSTANTIATION - 1"); + END IF; + + IF W /= 2 THEN + FAILED ("NEW OPERATOR NOT VISIBLE - " & + "INSTANTIATION"); + END IF; + + IF Z /= 2 THEN + FAILED ("OLD OPERATOR NOT DERIVED - " & + "INSTANTIATION - 1"); + END IF; + END Q; + + PACKAGE R IS + Y : QT := +0; + TYPE RT IS NEW QT; + Z : RT := +0; + END R; + USE R; + + BEGIN + IF Y /= 1 THEN + FAILED ("OLD OPERATOR NOT VISIBLE - INSTANTIATION - " & + "2"); + END IF; + + IF Z /= 1 THEN + FAILED ("OLD OPERATOR NOT DERIVED - INSTANTIATION - " & + "2"); + END IF; + END; + + ----------------------------------------------------------------- + + RESULT; +END C34014R; diff --git a/gcc-4.9/gcc/testsuite/ada/acats/tests/c3/c34014t.ada b/gcc-4.9/gcc/testsuite/ada/acats/tests/c3/c34014t.ada new file mode 100644 index 000000000..ddf22c6be --- /dev/null +++ b/gcc-4.9/gcc/testsuite/ada/acats/tests/c3/c34014t.ada @@ -0,0 +1,107 @@ +-- C34014T.ADA + +-- Grant of Unlimited Rights +-- +-- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687, +-- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained +-- unlimited rights in the software and documentation contained herein. +-- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making +-- this public release, the Government intends to confer upon all +-- recipients unlimited rights equal to those held by the Government. +-- These rights include rights to use, duplicate, release or disclose the +-- released technical data and computer software in whole or in part, in +-- any manner and for any purpose whatsoever, and to have or permit others +-- to do so. +-- +-- DISCLAIMER +-- +-- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR +-- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED +-- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF 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 DERIVED OPERATOR IS VISIBLE AND FURTHER DERIVABLE +-- UNDER APPROPRIATE CIRCUMSTANCES. + +-- CHECK WHEN THE DERIVED OPERATOR IS IMPLICITLY DECLARED IN THE +-- VISIBLE PART OF A PACKAGE AND NO HOMOGRAPHIC OPERATOR IS LATER +-- DECLARED EXPLICITLY. + +-- HISTORY: +-- JRK 09/22/87 CREATED ORIGINAL TEST. + +WITH REPORT; USE REPORT; + +PROCEDURE C34014T IS + + PACKAGE P IS + TYPE T IS RANGE -100 .. 100; + FUNCTION "+" (X : T) RETURN T; + END P; + USE P; + + PACKAGE BODY P IS + FUNCTION "+" (X : T) RETURN T IS + BEGIN + RETURN X + T (IDENT_INT (1)); + END "+"; + END P; + +BEGIN + TEST ("C34014T", "CHECK THAT A DERIVED OPERATOR IS VISIBLE " & + "AND FURTHER DERIVABLE UNDER APPROPRIATE " & + "CIRCUMSTANCES. CHECK WHEN THE DERIVED " & + "OPERATOR IS IMPLICITLY DECLARED IN THE " & + "VISIBLE PART OF A PACKAGE AND NO HOMOGRAPHIC " & + "OPERATOR IS LATER DECLARED EXPLICITLY"); + + ----------------------------------------------------------------- + + COMMENT ("NO NEW OPERATOR DECLARED EXPLICITLY"); + + DECLARE + + PACKAGE Q IS + TYPE QT IS NEW T; + X : QT := +0; + PRIVATE + TYPE QS IS NEW QT; + Z : QS := +0; + END Q; + USE Q; + + PACKAGE BODY Q IS + BEGIN + IF X /= 1 THEN + FAILED ("OLD OPERATOR NOT VISIBLE - 1"); + END IF; + + IF Z /= 1 THEN + FAILED ("OLD OPERATOR NOT DERIVED - 1"); + END IF; + END Q; + + PACKAGE R IS + Y : QT := +0; + TYPE RT IS NEW QT; + Z : RT := +0; + END R; + USE R; + + BEGIN + IF Y /= 1 THEN + FAILED ("OLD OPERATOR NOT VISIBLE - 2"); + END IF; + + IF Z /= 1 THEN + FAILED ("OLD OPERATOR NOT DERIVED - 2"); + END IF; + END; + + ----------------------------------------------------------------- + + RESULT; +END C34014T; diff --git a/gcc-4.9/gcc/testsuite/ada/acats/tests/c3/c34014u.ada b/gcc-4.9/gcc/testsuite/ada/acats/tests/c3/c34014u.ada new file mode 100644 index 000000000..209b06d1f --- /dev/null +++ b/gcc-4.9/gcc/testsuite/ada/acats/tests/c3/c34014u.ada @@ -0,0 +1,212 @@ +-- C34014U.ADA + +-- Grant of Unlimited Rights +-- +-- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687, +-- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained +-- unlimited rights in the software and documentation contained herein. +-- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making +-- this public release, the Government intends to confer upon all +-- recipients unlimited rights equal to those held by the Government. +-- These rights include rights to use, duplicate, release or disclose the +-- released technical data and computer software in whole or in part, in +-- any manner and for any purpose whatsoever, and to have or permit others +-- to do so. +-- +-- DISCLAIMER +-- +-- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR +-- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED +-- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF 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 DERIVED OPERATOR IS VISIBLE AND FURTHER DERIVABLE +-- UNDER APPROPRIATE CIRCUMSTANCES. + +-- CHECK WHEN THE DERIVED OPERATOR IS IMPLICITLY DECLARED IN THE +-- PRIVATE PART OF A PACKAGE AFTER AN EXPLICIT DECLARATION OF A +-- HOMOGRAPHIC OPERATOR IN THE VISIBLE PART. + +-- HISTORY: +-- JRK 09/23/87 CREATED ORIGINAL TEST. + +WITH REPORT; USE REPORT; + +PROCEDURE C34014U IS + + PACKAGE P IS + TYPE T IS RANGE -100 .. 100; + FUNCTION "+" (X : T) RETURN T; + END P; + USE P; + + PACKAGE BODY P IS + FUNCTION "+" (X : T) RETURN T IS + BEGIN + RETURN X + T (IDENT_INT (1)); + END "+"; + END P; + +BEGIN + TEST ("C34014U", "CHECK THAT A DERIVED OPERATOR IS VISIBLE " & + "AND FURTHER DERIVABLE UNDER APPROPRIATE " & + "CIRCUMSTANCES. CHECK WHEN THE DERIVED " & + "OPERATOR IS IMPLICITLY DECLARED IN THE " & + "PRIVATE PART OF A PACKAGE AFTER AN EXPLICIT " & + "DECLARATION OF A HOMOGRAPHIC OPERATOR IN " & + "THE VISIBLE PART"); + + ----------------------------------------------------------------- + + COMMENT ("NEW OPERATOR DECLARED BY SUBPROGRAM DECLARATION"); + + DECLARE + + PACKAGE Q IS + TYPE QT IS PRIVATE; + C0 : CONSTANT QT; + C2 : CONSTANT QT; + FUNCTION "+" (Y : QT) RETURN QT; + TYPE QR1 IS + RECORD + C : QT := +C0; + END RECORD; + PRIVATE + TYPE QT IS NEW T; + C0 : CONSTANT QT := 0; + C2 : CONSTANT QT := 2; + TYPE QR2 IS + RECORD + C : QT := +0; + END RECORD; + TYPE QS IS NEW QT; + END Q; + USE Q; + + PACKAGE BODY Q IS + FUNCTION "+" (Y : QT) RETURN QT IS + BEGIN + RETURN Y + QT (IDENT_INT (2)); + END "+"; + + PACKAGE R IS + X : QR1; + Y : QR2; + Z : QS := +0; + END R; + USE R; + BEGIN + IF X.C /= 2 THEN + FAILED ("NEW OPERATOR NOT VISIBLE - SUBPROG " & + "DECL - 1"); + END IF; + + IF Y.C /= 2 THEN + FAILED ("NEW OPERATOR NOT VISIBLE - SUBPROG " & + "DECL - 2"); + END IF; + + IF Z /= 2 THEN + FAILED ("NEW OPERATOR NOT DERIVED - SUBPROG " & + "DECL - 1"); + END IF; + END Q; + + PACKAGE R IS + Y : QT := +C0; + TYPE RT IS NEW QT; + Z : RT := +RT(C0); + END R; + USE R; + + BEGIN + IF Y /= C2 THEN + FAILED ("NEW OPERATOR NOT VISIBLE - SUBPROG DECL - 3"); + END IF; + + IF Z /= RT (C2) THEN + FAILED ("NEW OPERATOR NOT DERIVED - SUBPROG DECL - 2"); + END IF; + END; + + ----------------------------------------------------------------- + + COMMENT ("NEW OPERATOR DECLARED BY RENAMING"); + + DECLARE + + PACKAGE Q IS + TYPE QT IS PRIVATE; + C0 : CONSTANT QT; + C2 : CONSTANT QT; + FUNCTION G (X : QT) RETURN QT; + FUNCTION "+" (Y : QT) RETURN QT RENAMES G; + TYPE QR1 IS + RECORD + C : QT := +C0; + END RECORD; + PRIVATE + TYPE QT IS NEW T; + C0 : CONSTANT QT := 0; + C2 : CONSTANT QT := 2; + TYPE QR2 IS + RECORD + C : QT := +0; + END RECORD; + TYPE QS IS NEW QT; + END Q; + USE Q; + + PACKAGE BODY Q IS + FUNCTION G (X : QT) RETURN QT IS + BEGIN + RETURN X + QT (IDENT_INT (2)); + END G; + + PACKAGE R IS + X : QR1; + Y : QR2; + Z : QS := +0; + END R; + USE R; + BEGIN + IF X.C /= 2 THEN + FAILED ("NEW OPERATOR NOT VISIBLE - RENAMING - " & + "1"); + END IF; + + IF Y.C /= 2 THEN + FAILED ("NEW OPERATOR NOT VISIBLE - RENAMING - " & + "2"); + END IF; + + IF Z /= 2 THEN + FAILED ("NEW OPERATOR NOT DERIVED - RENAMING - " & + "1"); + END IF; + END Q; + + PACKAGE R IS + Y : QT := +C0; + TYPE RT IS NEW QT; + Z : RT := +RT(C0); + END R; + USE R; + + BEGIN + IF Y /= C2 THEN + FAILED ("NEW OPERATOR NOT VISIBLE - RENAMING - 3"); + END IF; + + IF Z /= RT (C2) THEN + FAILED ("NEW OPERATOR NOT DERIVED - RENAMING - 2"); + END IF; + END; + + ----------------------------------------------------------------- + + RESULT; +END C34014U; diff --git a/gcc-4.9/gcc/testsuite/ada/acats/tests/c3/c34018a.ada b/gcc-4.9/gcc/testsuite/ada/acats/tests/c3/c34018a.ada new file mode 100644 index 000000000..d039337fc --- /dev/null +++ b/gcc-4.9/gcc/testsuite/ada/acats/tests/c3/c34018a.ada @@ -0,0 +1,154 @@ +-- C34018A.ADA + +-- Grant of Unlimited Rights +-- +-- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687, +-- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained +-- unlimited rights in the software and documentation contained herein. +-- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making +-- this public release, the Government intends to confer upon all +-- recipients unlimited rights equal to those held by the Government. +-- These rights include rights to use, duplicate, release or disclose the +-- released technical data and computer software in whole or in part, in +-- any manner and for any purpose whatsoever, and to have or permit others +-- to do so. +-- +-- DISCLAIMER +-- +-- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR +-- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED +-- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF 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 CALLS OF DERIVED SUBPROGRAMS CHECK CONSTRAINTS OF THE +-- PARENT SUBPROGRAM, NOT THE CONSTRAINTS OF THE DERIVED SUBTYPE. + +-- JBG 11/15/85 +-- JRK 2/12/86 CORRECTED ERROR: RESOLVED AMBIGUOUS CALL G(41) TO +-- TYPE NEW_INT. +-- EDS 7/16/98 AVOID OPTIMIZATION + +WITH REPORT; USE REPORT; +PROCEDURE C34018A IS + + PACKAGE P IS + TYPE INT IS RANGE 1..100; + SUBTYPE INT_50 IS INT RANGE 1..50; + SUBTYPE INT_51 IS INT RANGE 51..100; + + FUNCTION "+" (L, R : INT) RETURN INT; + FUNCTION G (X : INT_50) RETURN INT_51; + + TYPE STR IS ARRAY (1..10) OF CHARACTER; + FUNCTION F (X : STR) RETURN STR; + END P; + + USE P; + + TYPE NEW_STR IS NEW P.STR; + TYPE NEW_INT IS NEW P.INT RANGE 51..90; + + PACKAGE BODY P IS + + FUNCTION "+" (L, R : INT) RETURN INT IS + BEGIN + RETURN INT(INTEGER(L) + INTEGER(R)); + END "+"; + + FUNCTION G (X : INT_50) RETURN INT_51 IS + BEGIN + RETURN X + 10; + END G; + + FUNCTION F (X : STR) RETURN STR IS + BEGIN + RETURN X; + END F; + + END P; + +BEGIN + + TEST ("C34018A", "CHECK CONSTRAINTS PROCESSED CORRECTLY FOR " & + "CALLS OF DERIVED SUBPROGRAMS"); + + DECLARE + + Y : NEW_STR := F("1234567890"); -- UNAMBIGUOUS. + + BEGIN + IF Y /= "1234567890" THEN + FAILED ("DERIVED F"); + END IF; + END; + + DECLARE + + A : INT := 51; + B : NEW_INT := NEW_INT(IDENT_INT(90)); + + BEGIN + + BEGIN + A := A + 0; + FAILED ("NO EXCEPTION - A + 0 = " & INT'IMAGE(A) ); --Use A + EXCEPTION + WHEN CONSTRAINT_ERROR => + NULL; + WHEN OTHERS => + FAILED ("UNEXPECTED EXCEPTION - 1"); + END; + + BEGIN + IF B + 2 /= 92 THEN -- 92 IN INT. + FAILED ("WRONG RESULT - B + 2"); + END IF; + EXCEPTION + WHEN CONSTRAINT_ERROR => + FAILED ("WRONG CONSTRAINT FOR DERIVED ""+"""); + WHEN OTHERS => + FAILED ("UNEXPECTED EXCEPTION - 2"); + END; + + BEGIN + IF B + 14 > 90 THEN -- 104 NOT IN INT. + FAILED ("NO EXCEPTION RAISED FOR DERIVED ""+"""); + END IF; + EXCEPTION + WHEN CONSTRAINT_ERROR => + NULL; + WHEN OTHERS => + FAILED ("UNEXPECTED EXCEPTION - 3"); + END; + + + BEGIN + IF G(B) > 90 THEN -- 90 NOT IN INT_50. + FAILED ("NO EXCEPTION RAISED FOR DERIVED G"); + END IF; + EXCEPTION + WHEN CONSTRAINT_ERROR => + NULL; + WHEN OTHERS => + FAILED ("UNEXPECTED EXCEPTION - 4"); + END; + + BEGIN + IF C34018A.G(41) /= 51 THEN -- 41 CONVERTED TO + -- NEW_INT'BASE. + -- 41 IN INT_50. + -- 51 IN INT_51. + FAILED ("WRONG RESULT - G(41)"); + END IF; + EXCEPTION + WHEN CONSTRAINT_ERROR => + FAILED ("C_E RAISED FOR LITERAL ARGUMENT"); + WHEN OTHERS => + FAILED ("UNEXPECTED EXCEPTION - 5"); + END; + END; + + RESULT; +END C34018A; diff --git a/gcc-4.9/gcc/testsuite/ada/acats/tests/c3/c340a01.a b/gcc-4.9/gcc/testsuite/ada/acats/tests/c3/c340a01.a new file mode 100644 index 000000000..108a30b5f --- /dev/null +++ b/gcc-4.9/gcc/testsuite/ada/acats/tests/c3/c340a01.a @@ -0,0 +1,165 @@ +-- C340A01.A +-- +-- Grant of Unlimited Rights +-- +-- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687, +-- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained +-- unlimited rights in the software and documentation contained herein. +-- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making +-- this public release, the Government intends to confer upon all +-- recipients unlimited rights equal to those held by the Government. +-- These rights include rights to use, duplicate, release or disclose the +-- released technical data and computer software in whole or in part, in +-- any manner and for any purpose whatsoever, and to have or permit others +-- to do so. +-- +-- DISCLAIMER +-- +-- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR +-- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED +-- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE +-- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE +-- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A +-- PARTICULAR PURPOSE OF SAID MATERIAL. +--* +-- +-- OBJECTIVE: +-- Check that a tagged type declared in a package specification +-- may be passed as a generic formal (tagged) private type to a generic +-- package declaration. Check that the formal type may be extended with +-- a record extension in the generic package. +-- +-- Check that, in the instance, the record extension inherits the +-- user-defined primitive subprograms of the tagged actual. +-- +-- TEST DESCRIPTION: +-- Declare a tagged type and an associated primitive subprogram in a +-- package specification (foundation code). Declare a generic package +-- which takes a tagged type as a formal parameter, and then extends +-- it with a record extension (foundation code). +-- +-- Instantiate the generic package with the tagged type from the first +-- package (the "generic" extension should now have inherited +-- the primitive subprogram of the tagged type from the first +-- package). +-- +-- In the main program, call the primitive subprogram inherited by the +-- "generic" extension, and verify the correctness of the components. +-- +-- TEST FILES: +-- This test consists of the following files: +-- +-- F340A000.A +-- F340A001.A +-- => C340A01.A +-- +-- +-- CHANGE HISTORY: +-- 06 Dec 94 SAIC ACVC 2.0 +-- 12 Jun 96 SAIC ACVC 2.1: Modified prologue. Removed extraneous +-- comments. +-- +--! + +with F340A001; -- Book definitions. +package C340A01_0 is -- Raw data to be used in creating book elements. + + + Book_Count : constant := 3; + + subtype Number_Of_Books is Integer range 1 .. Book_Count; + + type Data_List is array (Number_Of_Books) of F340A001.Text_Ptr; + + Title_List : Data_List := (new String'("Wuthering Heights"), + new String'("Heart of Darkness"), + new String'("Ulysses")); + + Author_List : Data_List := (new String'("Bronte, Emily"), + new String'("Conrad, Joseph"), + new String'("Joyce, James")); + +end C340A01_0; + + + --==================================================================-- + + +-- Library-level instantiation. Actual parameter is tagged record. + +with F340A001; -- Book definitions. +with F340A000; -- Singly-linked list abstraction. +package C340A01_1 is new F340A000 (Parent_Type => F340A001.Book_Type); + + + --==================================================================-- + + +with Report; + +with F340A001; -- Book definitions. +with C340A01_0; -- Raw book data. +with C340A01_1; -- Instance. + +use F340A001; -- Primitive operations of Book_Type directly visible. +use C340A01_1; -- Operations inherited by Node_Type directly visible. + +procedure C340A01 is + + + List_Of_Books : Node_Ptr := null; -- Head of linked list of books. + + + --========================================================-- + + + procedure Create_List (Title, Author : in C340A01_0.Data_List; + Head : in out Node_Ptr) is + + Book : Node_Type; -- Object of extended type. + Book_Ptr : Node_Ptr; + + begin + for I in C340A01_0.Number_Of_Books loop + Create_Book (Title (I), Author (I), Book); -- Call inherited + -- operation. + Book_Ptr := new Node_Type'(Book); + Add (Book_Ptr, Head); + end loop; + end Create_List; + + + --========================================================-- + + + function Bad_List_Contents return Boolean is + begin + return (List_Of_Books.Title.all /= "Ulysses" or + List_Of_Books.Author.all /= "Joyce, James" or + List_Of_Books.Next.Title.all /= "Heart of Darkness" or + List_Of_Books.Next.Author.all /= "Conrad, Joseph" or + List_Of_Books.Next.Next.Title.all /= "Wuthering Heights" or + List_Of_Books.Next.Next.Author.all /= "Bronte, Emily"); + end Bad_List_Contents; + + + --========================================================-- + + +begin -- Main program. + + Report.Test ("C340A01", "Inheritance of primitive operations: record " & + "extension of formal tagged private type; actual is " & + "an ultimate ancestor type"); + + -- Create linked list using inherited operation: + Create_List (C340A01_0.Title_List, C340A01_0.Author_List, List_Of_Books); + + -- Verify results: + if Bad_List_Contents then + Report.Failed ("Wrong values after call to inherited operation"); + end if; + + Report.Result; + +end C340A01; diff --git a/gcc-4.9/gcc/testsuite/ada/acats/tests/c3/c340a02.a b/gcc-4.9/gcc/testsuite/ada/acats/tests/c3/c340a02.a new file mode 100644 index 000000000..2dd8f175c --- /dev/null +++ b/gcc-4.9/gcc/testsuite/ada/acats/tests/c3/c340a02.a @@ -0,0 +1,221 @@ +-- C340A02.A +-- +-- Grant of Unlimited Rights +-- +-- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687, +-- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained +-- unlimited rights in the software and documentation contained herein. +-- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making +-- this public release, the Government intends to confer upon all +-- recipients unlimited rights equal to those held by the Government. +-- These rights include rights to use, duplicate, release or disclose the +-- released technical data and computer software in whole or in part, in +-- any manner and for any purpose whatsoever, and to have or permit others +-- to do so. +-- +-- DISCLAIMER +-- +-- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR +-- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED +-- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE +-- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE +-- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A +-- PARTICULAR PURPOSE OF SAID MATERIAL. +--* +-- +-- OBJECTIVE: +-- Check that a record extension (declared in a package specification) of +-- a tagged type (declared in a different package specification) may be +-- passed as a generic formal (tagged) private type to a generic package +-- declaration. Check that the formal type may be further extended with a +-- record extension in the generic package. +-- +-- Check that, in the instance, the record extension inherits the +-- user-defined primitive subprograms of the tagged actual, including +-- those inherited by the actual from its parent. +-- +-- TEST DESCRIPTION: +-- Declare a tagged type and an associated primitive subprogram in a +-- package specification (foundation code). Declare a record extension +-- of the tagged type and an associated primitive subprogram in a second +-- package specification. Declare a generic package which takes a tagged +-- type as a formal parameter, and then extends it with a record +-- extension (foundation code). +-- +-- Instantiate the generic package with the record extension from the +-- second package (the "generic" extension should now have inherited +-- the primitive subprograms of the record extension from the second +-- package). +-- +-- In the main program, call the primitive subprograms inherited by the +-- "generic" extension. There are two: (1) Create_Book, declared for +-- the root tagged type in the first package (inherited by the record +-- extension of the second package, and then in turn by the "generic" +-- extension), and (2) Update_Pages, declared for the record extension +-- in the second package. Verify the correctness of the components. +-- +-- TEST FILES: +-- This test consists of the following files: +-- +-- F340A000.A +-- F340A001.A +-- => C340A02.A +-- +-- +-- CHANGE HISTORY: +-- 06 Dec 94 SAIC ACVC 2.0 +-- 12 Jun 96 SAIC ACVC 2.1: Modified prologue. Removed extraneous +-- comments. +-- +--! + +with F340A001; -- Book definitions. +package C340A02_0 is -- Extended book abstraction. + + + type Detailed_Book_Type is new F340A001.Book_Type with record + Pages : Natural; -- Record ext. + end record; -- of root tagged + -- type. + + -- Inherits Create_Book from Book_Type. + + procedure Update_Pages (Book : in out Detailed_Book_Type; -- Primitive op. + Pages : in Natural); -- of extension. + + +end C340A02_0; + + + --==================================================================-- + + +package body C340A02_0 is + + + procedure Update_Pages (Book : in out Detailed_Book_Type; + Pages : in Natural) is + begin + Book.Pages := Pages; + end Update_Pages; + + +end C340A02_0; + + + --==================================================================-- + + +with F340A001; -- Book definitions. +package C340A02_1 is -- Raw data to be used in creating book elements. + + + Book_Count : constant := 3; + + subtype Number_Of_Books is Integer range 1 .. Book_Count; + + type Data_List is array (Number_Of_Books) of F340A001.Text_Ptr; + type Page_Counts is array (Number_Of_Books) of Natural; + + Title_List : Data_List := (new String'("Wuthering Heights"), + new String'("Heart of Darkness"), + new String'("Ulysses")); + + Author_List : Data_List := (new String'("Bronte, Emily"), + new String'("Conrad, Joseph"), + new String'("Joyce, James")); + + Page_List : Page_Counts := (237, 215, 456); + +end C340A02_1; + + + --==================================================================-- + + +-- Library-level instantiation. Actual parameter is record extension. + +with C340A02_0; -- Extended book abstraction. +with F340A000; -- Singly-linked list abstraction. +package C340A02_2 is new F340A000 + (Parent_Type => C340A02_0.Detailed_Book_Type); + + + --==================================================================-- + + +with Report; + +with C340A02_0; -- Extended book abstraction. +with C340A02_1; -- Raw book data. +with C340A02_2; -- Instance. + +use C340A02_0; -- Primitive operations of Detailed_Book_Type directly visible. +use C340A02_2; -- Operations inherited by Node_Type directly visible. + +procedure C340A02 is + + + List_Of_Books : Node_Ptr := null; -- Head of linked list of books. + + + --========================================================-- + + + procedure Create_List (Title, Author : in C340A02_1.Data_List; + Pages : in C340A02_1.Page_Counts; + Head : in out Node_Ptr) is + + Book : Node_Type; -- Object of extended type. + Book_Ptr : Node_Ptr; + + begin + for I in C340A02_1.Number_Of_Books loop + Create_Book (Title (I), Author (I), Book); -- Call twice-inherited + -- operation. + Update_Pages (Book, Pages (I)); -- Call inherited op. + Book_Ptr := new Node_Type'(Book); + Add (Book_Ptr, Head); + end loop; + end Create_List; + + + --========================================================-- + + + function Bad_List_Contents return Boolean is + begin + return (List_Of_Books.Title.all /= "Ulysses" or + List_Of_Books.Author.all /= "Joyce, James" or + List_Of_Books.Pages /= 456 or + List_Of_Books.Next.Title.all /= "Heart of Darkness" or + List_Of_Books.Next.Author.all /= "Conrad, Joseph" or + List_Of_Books.Next.Pages /= 215 or + List_Of_Books.Next.Next.Title.all /= "Wuthering Heights" or + List_Of_Books.Next.Next.Author.all /= "Bronte, Emily" or + List_Of_Books.Next.Next.Pages /= 237); + + end Bad_List_Contents; + + + --========================================================-- + + +begin -- Main program. + + Report.Test ("C340A02", "Inheritance of primitive operations: record " & + "extension of formal tagged private type; actual is " & + "a record extension"); + + -- Create linked list using inherited operation: + Create_List (C340A02_1.Title_List, C340A02_1.Author_List, + C340A02_1.Page_List, List_Of_Books); + + -- Verify results: + if Bad_List_Contents then + Report.Failed ("Wrong values after call to inherited operations"); + end if; + + Report.Result; + +end C340A02; diff --git a/gcc-4.9/gcc/testsuite/ada/acats/tests/c3/c341a01.a b/gcc-4.9/gcc/testsuite/ada/acats/tests/c3/c341a01.a new file mode 100644 index 000000000..34a1eeeaa --- /dev/null +++ b/gcc-4.9/gcc/testsuite/ada/acats/tests/c3/c341a01.a @@ -0,0 +1,117 @@ +-- C341A01.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 formal parameters of a class-wide type can be passed +-- values of any specific type within the class. +-- +-- TEST DESCRIPTION: +-- Define an object of a root tagged type and of various types derived +-- from the root. Define objects of the root class, and initialize them +-- by parameter association of objects of the specific types (root and +-- extended types) within the class. +-- +-- The particular root and extended types used in this abstraction are +-- defined in foundation code (F341A00.A), and are graphically displayed +-- as follows: +-- +-- package Bank +-- type Account +-- | +-- | +-- | +-- package Checking +-- type Account +-- | +-- | +-- | +-- package Interest_Checking +-- type Account +-- +-- +-- TEST FILES: +-- This test depends on the following foundation code: +-- +-- F341A00.A +-- +-- The following files comprise this test: +-- +-- => C341A01.A +-- +-- +-- CHANGE HISTORY: +-- 06 Dec 94 SAIC ACVC 2.0 +-- +--! + +with F341A00_0; -- package Bank +with F341A00_1; -- package Checking +with F341A00_2; -- package Interest_Checking +with Report; + +procedure C341A01 is + + package Bank renames F341A00_0; + use type Bank.Dollar_Amount; + package Checking renames F341A00_1; + package Interest_Checking renames F341A00_2; + + Max_Accts : constant := 3; + Bank_Balance : Bank.Dollar_Amount := 0.00; + + -- Initialize objects of specific tagged types. + B_Acct : Bank.Account := (Current_Balance => 10.00); + C_Acct : Checking.Account := (100.00, 10.00); + IC_Acct : Interest_Checking.Account := (1000.00, 10.00, 0.030); + + -- Define and initialize (by parameter association) objects of class-wide + -- type originating from the root type (Bank.Account). + + -- Define an account auditing procedure with a class-wide + -- variable that can hold a value of any object within the class. + procedure Audit (Next_Account : Bank.Account'Class) is + begin + Bank_Balance := Bank_Balance + Next_Account.Current_Balance; + end Audit; + + +begin -- C341A01 + + Report.Test ("C341A01", "Check that objects of a class-wide type can " & + "be initialized, by direct assignment, to a " & + "value of any specific type within the class" ); + + -- Perform nightly audit of total funds on deposit in bank. + Audit (B_Acct); + Audit (C_Acct); + Audit (IC_Acct); + + if Bank_Balance /= 1110.00 then + Report.Failed ("Class-wide object processing failed"); + end if; + + Report.Result; + +end C341A01; diff --git a/gcc-4.9/gcc/testsuite/ada/acats/tests/c3/c341a02.a b/gcc-4.9/gcc/testsuite/ada/acats/tests/c3/c341a02.a new file mode 100644 index 000000000..4fa9842bf --- /dev/null +++ b/gcc-4.9/gcc/testsuite/ada/acats/tests/c3/c341a02.a @@ -0,0 +1,145 @@ +-- C341A02.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 class-wide objects can be reassigned with objects from + -- the same specific type used to initialize them. + -- + -- TEST DESCRIPTION: + -- Define new objects of specific types from within a class. Reassign + -- previously declared class-wide objects with the new specific type + -- objects. Check that new assignments were performed. + -- + -- The particular root and extended types used in this abstraction are + -- defined in foundation code (F341A00.A), and are graphically displayed + -- as follows: + -- + -- package Bank + -- type Account + -- | + -- | + -- | + -- package Checking + -- type Account + -- | + -- | + -- | + -- package Interest_Checking + -- type Account + -- + -- TEST FILES: + -- This test depends on the following foundation code: + -- + -- F341A00.A + -- + -- The following files comprise this test: + -- + -- => C341A02.A + -- + -- +-- CHANGE HISTORY: +-- 06 Dec 94 SAIC ACVC 2.0 +-- + --! + + with F341A00_0; -- package Bank + with F341A00_1; -- package Checking + with F341A00_2; -- package Interest_Checking + with Report; + + procedure C341A02 is + + package Bank renames F341A00_0; + package Checking renames F341A00_1; + package Interest_Checking renames F341A00_2; + + Max_Accts : constant := 3; + Bank_Balance : Bank.Dollar_Amount := 0.00; + + -- Define and initialize objects of specific types. + B_Acct : aliased Bank.Account := (Current_Balance => 10.00); + C_Acct : aliased Checking.Account := (100.00, 10.00); + IC_Acct : aliased Interest_Checking.Account := (1000.00, 10.00, 0.030); + New_B_Acct : aliased Bank.Account := (Current_Balance => 20.00); + New_C_Acct : aliased Checking.Account := (200.00, 20.00); + New_IC_Acct : aliased Interest_Checking.Account := (2000.00, 20.00, 0.060); + + + -- Define and initialize (by direct assignment) objects of a class-wide + -- type originating from the root type (Bank.Account). + + type ATM_Card is access all Bank.Account'Class; + + Accounts : array (1 .. Max_Accts) of ATM_Card := + (1 => B_Acct'Access, 2 => C_Acct'Access, 3 => IC_Acct'Access); + + New_Accounts : array (1 .. Max_Accts) of ATM_Card := + (1 => New_B_Acct'Access, + 2 => New_C_Acct'Access, + 3 => New_IC_Acct'Access); + + -- Define an account auditing procedure with a class-wide + -- variable that can hold a value of any object within the class, + -- and once initialized, can hold other values of the same specific type. + + procedure Audit (Num : in integer; + Amt : out Bank.Dollar_Amount) is + Account_Being_Audited : Bank.Account'Class := Accounts(Num).all; + use type Bank.Dollar_Amount; + begin + Amt := Account_Being_Audited.Current_Balance; + -- Reassign class-wide variable to another object of the type used to + -- initialize it. + Account_Being_Audited := New_Accounts(Num).all; + Amt := Amt + Account_Being_Audited.Current_Balance; -- Reading OUT + end Audit; -- parameter. + + + begin + + Report.Test ("C341A02", "Check that class-wide objects can be " & + "reassigned with objects from the same " & + "specific type used to initialize them" ); + Night_Audit: + declare + use type Bank.Dollar_Amount; + Acct_Value : Bank.Dollar_Amount := 0.00; + begin + -- Perform nightly audit of total funds on deposit in bank. + for i in 1 .. Max_Accts loop + Audit (i, Acct_Value); + Bank_Balance := Bank_Balance + Acct_Value; + end loop; + + if Bank_Balance /= 3330.00 then + Report.Failed ("Class-wide object processing failed"); + end if; + + end Night_Audit; + + Report.Result; + + end C341A02; + diff --git a/gcc-4.9/gcc/testsuite/ada/acats/tests/c3/c341a03.a b/gcc-4.9/gcc/testsuite/ada/acats/tests/c3/c341a03.a new file mode 100644 index 000000000..0911e636d --- /dev/null +++ b/gcc-4.9/gcc/testsuite/ada/acats/tests/c3/c341a03.a @@ -0,0 +1,140 @@ +-- C341A03.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 object of one class-wide type can initialize a +-- class-wide object of a different type when the operation is embedded +-- in a generic unit. +-- +-- TEST DESCRIPTION: +-- Declare specific-type objects of an extended type. Declare an array +-- of access values designating class-wide objects, initialized to point +-- to the objects of the specific type. Define a generic subprogram +-- having a generic formal derived type parameter. Within the generic, +-- declare a class-wide variable of the formal parameter type. Verify +-- that the variable can be initialized with the value of an object +-- of another class-wide type within the class. +-- +-- The particular root and extended types used in this abstraction are +-- defined in foundation code (F341A00.A), and are graphically displayed +-- as follows: +-- +-- package Bank +-- type Account +-- | +-- | +-- | +-- package Checking +-- type Account +-- | +-- | +-- | +-- package Interest_Checking +-- type Account +-- +-- TEST FILES: +-- This test depends on the following foundation code: +-- +-- F341A00.A +-- +-- +-- CHANGE HISTORY: +-- 06 Dec 94 SAIC ACVC 2.0 +-- 16 Dec 94 SAIC Changed level of 'Class for ATM_Card +-- +--! + +with F341A00_0; -- package Bank +generic + type Account_Type is new F341A00_0.Account with private; -- new Bank.Account +function C341A03_0 (The_Account : Account_Type'Class) -- function Audit + return F341A00_0.Dollar_Amount; + +function C341A03_0 (The_Account : Account_Type'Class) + return F341A00_0.Dollar_Amount is + Acct : Account_Type'Class := The_Account; -- Init. of class-wide with +begin -- another class-wide object. + return Acct.Current_Balance; +end C341A03_0; + + + --=================================================================-- + + +with F341A00_0; -- package Bank +with F341A00_1; -- package Checking +with C341A03_0; -- generic function Audit +with Report; + +procedure C341A03 is + + package Bank renames F341A00_0; + package Checking renames F341A00_1; + + Current_Checking_Accounts : constant := 3; + + Checking_Acct1 : aliased Checking.Account := (Current_Balance => 10.00, + Overdraft_Fee => 5.00); + Checking_Acct2 : aliased Checking.Account := (Current_Balance => 20.00, + Overdraft_Fee => 5.00); + Checking_Acct3 : aliased Checking.Account := (Current_Balance => 30.00, + Overdraft_Fee => 5.00); + + type ATM_Card is access all Checking.Account'Class; + + -- Declare array of accesses to class-wide objects. + Account_Array : array (1 .. Current_Checking_Accounts) of + ATM_Card := (Checking_Acct1'Access, + Checking_Acct2'Access, + Checking_Acct3'Access); +begin -- C341A03 + + Report.Test ("C341A03", "Check that an object of one class-wide type " & + "can initialize a class-wide object of a " & + "different type when the operation is embedded " & + "in a generic unit" ); + + Audit_Checking_Accounts: + declare + Balance_In_Checking_Accounts : Bank.Dollar_Amount := 0.00; + -- Instantiate with a specific extended type. + function Checking_Audit is new C341A03_0 (Checking.Account); + use type Bank.Dollar_Amount; + begin + + for I in 1 .. Current_Checking_Accounts loop + Balance_In_Checking_Accounts := Balance_In_Checking_Accounts + + Checking_Audit (Account_Array (I).all); + end loop; + + if Balance_In_Checking_Accounts /= 60.00 then + Report.Failed ("Incorrect initialization of class-wide object"); + end if; + + end Audit_Checking_Accounts; + + Report.Result; + +end C341A03; diff --git a/gcc-4.9/gcc/testsuite/ada/acats/tests/c3/c341a04.a b/gcc-4.9/gcc/testsuite/ada/acats/tests/c3/c341a04.a new file mode 100644 index 000000000..d7392568e --- /dev/null +++ b/gcc-4.9/gcc/testsuite/ada/acats/tests/c3/c341a04.a @@ -0,0 +1,141 @@ +-- C341A04.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 class-wide objects can be initialized using allocation. + -- + -- TEST DESCRIPTION: + -- Declare access types that refer to class-wide types, one with basis + -- of the root type, another with basis of a type extended from the root. + -- Declare objects of these access types, and allocate class-wide + -- objects, initialized to values of specific types within the particular + -- classes. + -- + -- The particular root and extended types used in this abstraction are + -- defined in foundation code (F341A00.A), and are graphically displayed + -- as follows: + -- + -- package Bank + -- type Account + -- | + -- | + -- | + -- package Checking + -- type Account + -- | + -- | + -- | + -- package Interest_Checking + -- type Account + -- + -- TEST FILES: + -- This test depends on the following foundation code: + -- + -- F341A00.A + -- + -- The following files comprise this test: + -- + -- => C341A04.A + -- + -- +-- CHANGE HISTORY: +-- 06 Dec 94 SAIC ACVC 2.0 +-- + --! + + with F341A00_0; -- package Bank + with F341A00_1; -- package Checking + with F341A00_2; -- package Interest_Checking + with Report; + + procedure C341A04 is + + package Bank renames F341A00_0; + package Checking renames F341A00_1; + package Interest_Checking renames F341A00_2; + + use type Bank.Dollar_Amount; + + Max_Accts : constant := 3; + Bank_Balance : Bank.Dollar_Amount := 0.00; + + -- Define access types referring to class of types rooted at + -- Bank.Account (root). + + type Bank_Account_Pointer is access Bank.Account'Class; + + -- + -- Define class-wide objects, initializing them through allocation. + -- + + -- Initialized to specific type that is basis of class. + Bank_Acct : Bank_Account_Pointer := + new Bank.Account'(Current_Balance => 10.00); + + -- Initialized to specific type that has been extended from the basis + -- of the class. + Checking_Acct : Bank_Account_Pointer := + new Checking.Account'(Current_Balance => 100.00, + Overdraft_Fee => 10.00); + + -- Initialized to specific type that has been twice extended from the + -- basis of the class. + IC_Acct : Bank_Account_Pointer := + new Interest_Checking.Account'(Current_Balance => 1000.00, + Overdraft_Fee => 10.00, + Rate => 0.030); + + -- Declare and initialize array of pointers to objects of + -- Bank.Account'Class. + + Accounts : array (1 .. Max_Accts) of Bank_Account_Pointer := + (Bank_Acct, Checking_Acct, IC_Acct); + + + -- Audit will process any account object within Bank.Account'Class. + + function Audit (Ptr : Bank_Account_Pointer) return Bank.Dollar_Amount is + begin + return (Ptr.Current_Balance); + end Audit; + + + begin -- C341A04 + + Report.Test ("C341A04", "Check that class-wide objects were " & + "successfully initialized using allocation" ); + + for i in 1 .. Max_Accts loop + Bank_Balance := Bank_Balance + Audit (Accounts(i)); + end loop; + + if Bank_Balance /= 1110.00 then + Report.Failed ("Failed class-wide object allocation"); + end if; + + Report.Result; + + end C341A04; + diff --git a/gcc-4.9/gcc/testsuite/ada/acats/tests/c3/c35003a.ada b/gcc-4.9/gcc/testsuite/ada/acats/tests/c3/c35003a.ada new file mode 100644 index 000000000..c384683fd --- /dev/null +++ b/gcc-4.9/gcc/testsuite/ada/acats/tests/c3/c35003a.ada @@ -0,0 +1,234 @@ +-- C35003A.ADA + +-- Grant of Unlimited Rights +-- +-- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687, +-- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained +-- unlimited rights in the software and documentation contained herein. +-- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making +-- this public release, the Government intends to confer upon all +-- recipients unlimited rights equal to those held by the Government. +-- These rights include rights to use, duplicate, release or disclose the +-- released technical data and computer software in whole or in part, in +-- any manner and for any purpose whatsoever, and to have or permit others +-- to do so. +-- +-- DISCLAIMER +-- +-- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR +-- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED +-- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE +-- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE +-- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A +-- PARTICULAR PURPOSE OF SAID MATERIAL. +--* +-- OBJECTIVE: +-- CHECK THAT CONSTRAINT_ERROR IS RAISED FOR AN INTEGER OR +-- ENUMERATION SUBTYPE INDICATION WHEN THE LOWER OR UPPER BOUND +-- OF A NON-NULL RANGE LIES OUTSIDE THE RANGE OF THE TYPE MARK. + +-- HISTORY: +-- JET 01/25/88 CREATED ORIGINAL TEST. + +WITH REPORT; USE REPORT; + +PROCEDURE C35003A IS + + TYPE ENUM IS (ZERO, ONE, TWO, THREE); + SUBTYPE SUBENUM IS ENUM RANGE ONE..TWO; + TYPE INT IS RANGE 1..10; + SUBTYPE SUBINT IS INTEGER RANGE -10..10; + TYPE A1 IS ARRAY (0..11) OF INTEGER; + TYPE A2 IS ARRAY (INTEGER RANGE -11..10) OF INTEGER; + +BEGIN + TEST ("C35003A", "CHECK THAT CONSTRAINT_ERROR IS RAISED FOR AN " & + "INTEGER OR ENUMERATION SUBTYPE INDICATION " & + "WHEN THE LOWER OR UPPER BOUND OF A NON-NULL " & + "RANGE LIES OUTSIDE THE RANGE OF THE TYPE MARK"); + BEGIN + DECLARE + SUBTYPE SUBSUBENUM IS SUBENUM RANGE ZERO..TWO; + BEGIN + FAILED ("NO EXCEPTION RAISED (E1)"); + DECLARE + Z : SUBSUBENUM := ONE; + BEGIN + IF NOT EQUAL(SUBSUBENUM'POS(Z),SUBSUBENUM'POS(Z)) + THEN + COMMENT ("DON'T OPTIMIZE Z"); + END IF; + END; + EXCEPTION + WHEN OTHERS => + FAILED ("EXCEPTION RAISED IN WRONG PLACE (E1)"); + END; + EXCEPTION + WHEN CONSTRAINT_ERROR => + NULL; + WHEN OTHERS => + FAILED ("WRONG EXCEPTION RAISED (E1)"); + END; + + BEGIN + DECLARE + TYPE A IS ARRAY (SUBENUM RANGE ONE..THREE) OF INTEGER; + BEGIN + FAILED ("NO EXCEPTION RAISED (E2)"); + DECLARE + Z : A := (OTHERS => 0); + BEGIN + IF NOT EQUAL(Z(ONE),Z(ONE)) THEN + COMMENT ("DON'T OPTIMIZE Z"); + END IF; + END; + EXCEPTION + WHEN OTHERS => + FAILED ("EXCEPTION RAISED IN WRONG PLACE (E2)"); + END; + EXCEPTION + WHEN CONSTRAINT_ERROR => + NULL; + WHEN OTHERS => + FAILED ("WRONG EXCEPTION RAISED (E2)"); + END; + + BEGIN + DECLARE + TYPE I IS ACCESS INT RANGE INT(IDENT_INT(0))..10; + BEGIN + FAILED ("NO EXCEPTION RAISED (I1)"); + DECLARE + Z : I := NEW INT'(1); + BEGIN + IF NOT EQUAL(INTEGER(Z.ALL),INTEGER(Z.ALL)) THEN + COMMENT ("DON'T OPTIMIZE Z"); + END IF; + END; + EXCEPTION + WHEN OTHERS => + FAILED ("EXCEPTION RAISED IN WRONG PLACE (I1)"); + END; + EXCEPTION + WHEN CONSTRAINT_ERROR => + NULL; + WHEN OTHERS => + FAILED ("WRONG EXCEPTION RAISED (I1)"); + END; + + BEGIN + DECLARE + TYPE I IS NEW INT RANGE 1..INT'SUCC(10); + BEGIN + FAILED ("NO EXCEPTION RAISED (I2)"); + DECLARE + Z : I := 1; + BEGIN + IF NOT EQUAL(INTEGER(Z),INTEGER(Z)) THEN + COMMENT ("DON'T OPTIMIZE Z"); + END IF; + END; + EXCEPTION + WHEN OTHERS => + FAILED ("EXCEPTION RAISED IN WRONG PLACE (I2)"); + END; + EXCEPTION + WHEN CONSTRAINT_ERROR => + NULL; + WHEN OTHERS => + FAILED ("WRONG EXCEPTION RAISED (I2)"); + END; + + BEGIN + DECLARE + TYPE R IS RECORD + A : SUBINT RANGE IDENT_INT(-11)..0; + END RECORD; + BEGIN + FAILED ("NO EXCEPTION RAISED (S1)"); + DECLARE + Z : R := (A => 1); + BEGIN + IF NOT EQUAL(INTEGER(Z.A),INTEGER(Z.A)) THEN + COMMENT ("DON'T OPTIMIZE Z"); + END IF; + END; + EXCEPTION + WHEN OTHERS => + FAILED ("EXCEPTION RAISED IN WRONG PLACE (S1)"); + END; + EXCEPTION + WHEN CONSTRAINT_ERROR => + NULL; + WHEN OTHERS => + FAILED ("WRONG EXCEPTION RAISED (S1)"); + END; + + BEGIN + DECLARE + Z : SUBINT RANGE 0..IDENT_INT(11) := 0; + BEGIN + FAILED ("NO EXCEPTION RAISED (S2)"); + IF NOT EQUAL(INTEGER(Z),INTEGER(Z)) THEN + COMMENT ("DON'T OPTIMIZE Z"); + END IF; + EXCEPTION + WHEN OTHERS => + FAILED ("EXCEPTION RAISED IN WRONG PLACE (S2)"); + END; + EXCEPTION + WHEN CONSTRAINT_ERROR => + NULL; + WHEN OTHERS => + FAILED ("WRONG EXCEPTION RAISED (S2)"); + END; + + BEGIN + DECLARE + SUBTYPE I IS SUBINT RANGE A1'RANGE; + BEGIN + FAILED ("NO EXCEPTION RAISED (R1)"); + DECLARE + Z : I := 1; + BEGIN + IF NOT EQUAL(INTEGER(Z),INTEGER(Z)) THEN + COMMENT ("DON'T OPTIMIZE Z"); + END IF; + END; + EXCEPTION + WHEN OTHERS => + FAILED ("EXCEPTION RAISED IN WRONG PLACE (R1)"); + END; + EXCEPTION + WHEN CONSTRAINT_ERROR => + NULL; + WHEN OTHERS => + FAILED ("WRONG EXCEPTION RAISED (R1)"); + END; + + BEGIN + DECLARE + SUBTYPE I IS SUBINT RANGE A2'RANGE; + BEGIN + FAILED ("NO EXCEPTION RAISED (R2)"); + DECLARE + Z : I := 1; + BEGIN + IF NOT EQUAL(INTEGER(Z),INTEGER(Z)) THEN + COMMENT ("DON'T OPTIMIZE Z"); + END IF; + END; + EXCEPTION + WHEN OTHERS => + FAILED ("EXCEPTION RAISED IN WRONG PLACE (R2)"); + END; + EXCEPTION + WHEN CONSTRAINT_ERROR => + NULL; + WHEN OTHERS => + FAILED ("WRONG EXCEPTION RAISED (R2)"); + END; + + RESULT; + +END C35003A; diff --git a/gcc-4.9/gcc/testsuite/ada/acats/tests/c3/c35003b.ada b/gcc-4.9/gcc/testsuite/ada/acats/tests/c3/c35003b.ada new file mode 100644 index 000000000..3eebde438 --- /dev/null +++ b/gcc-4.9/gcc/testsuite/ada/acats/tests/c3/c35003b.ada @@ -0,0 +1,217 @@ +-- C35003B.ADA + +-- Grant of Unlimited Rights +-- +-- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687, +-- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained +-- unlimited rights in the software and documentation contained herein. +-- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making +-- this public release, the Government intends to confer upon all +-- recipients unlimited rights equal to those held by the Government. +-- These rights include rights to use, duplicate, release or disclose the +-- released technical data and computer software in whole or in part, in +-- any manner and for any purpose whatsoever, and to have or permit others +-- to do so. +-- +-- DISCLAIMER +-- +-- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR +-- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED +-- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE +-- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE +-- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A +-- PARTICULAR PURPOSE OF SAID MATERIAL. +--* +-- OBJECTIVE: +-- CHECK THAT CONSTRAINT_ERROR IS RAISED FOR A SUBTYPE INDICATION +-- OF A DISCRETE GENERIC FORMAL TYPE WHEN THE LOWER OR UPPER BOUND +-- OF A NON-NULL RANGE LIES OUTSIDE THE RANGE OF THE TYPE MARK. + +-- HISTORY: +-- JET 07/08/88 CREATED ORIGINAL TEST. + +WITH REPORT; USE REPORT; + +PROCEDURE C35003B IS + + TYPE ENUM IS (WE, LOVE, WRITING, TESTS); + TYPE INT IS RANGE -10..10; + + GENERIC + TYPE GEN_ENUM IS (<>); + TYPE GEN_INT IS RANGE <>; + PACKAGE GEN_PACK IS + SUBTYPE SUBENUM IS GEN_ENUM RANGE + GEN_ENUM'SUCC(GEN_ENUM'FIRST) .. + GEN_ENUM'PRED(GEN_ENUM'LAST); + SUBTYPE SUBINT IS GEN_INT RANGE + GEN_INT'SUCC(GEN_INT'FIRST) .. + GEN_INT'PRED(GEN_INT'LAST); + TYPE A1 IS ARRAY (0..GEN_INT'LAST) OF INTEGER; + TYPE A2 IS ARRAY (GEN_INT RANGE GEN_INT'FIRST..0) OF INTEGER; + END GEN_PACK; + + PACKAGE BODY GEN_PACK IS + BEGIN + TEST ("C35003B", "CHECK THAT CONSTRAINT_ERROR IS RAISED " & + "FOR A SUBTYPE INDICATION OF A DISCRETE " & + "GENERIC FORMAL TYPE WHEN THE LOWER OR " & + "UPPER BOUND OF A NON-NULL RANGE LIES " & + "OUTSIDE THE RANGE OF THE TYPE MARK"); + BEGIN + DECLARE + SUBTYPE SUBSUBENUM IS SUBENUM RANGE + GEN_ENUM'FIRST..SUBENUM'LAST; + BEGIN + FAILED ("NO EXCEPTION RAISED (E1)"); + DECLARE + Z : SUBSUBENUM := SUBENUM'FIRST; + BEGIN + IF NOT EQUAL(SUBSUBENUM'POS(Z), + SUBSUBENUM'POS(Z)) THEN + COMMENT ("DON'T OPTIMIZE Z"); + END IF; + END; + EXCEPTION + WHEN OTHERS => + FAILED ("EXCEPTION RAISED IN WRONG " & + "PLACE (E1)"); + END; + EXCEPTION + WHEN CONSTRAINT_ERROR => + NULL; + WHEN OTHERS => + FAILED ("WRONG EXCEPTION RAISED (E1)"); + END; + + BEGIN + DECLARE + TYPE A IS ARRAY (SUBENUM RANGE SUBENUM'FIRST .. + GEN_ENUM'LAST) OF INTEGER; + BEGIN + FAILED ("NO EXCEPTION RAISED (E2)"); + DECLARE + Z : A := (OTHERS => 0); + BEGIN + IF NOT EQUAL(Z(SUBENUM'FIRST), + Z(SUBENUM'FIRST)) THEN + COMMENT ("DON'T OPTIMIZE Z"); + END IF; + END; + EXCEPTION + WHEN OTHERS => + FAILED ("EXCEPTION RAISED IN WRONG PLACE " & + "(E2)"); + END; + EXCEPTION + WHEN CONSTRAINT_ERROR => + NULL; + WHEN OTHERS => + FAILED ("WRONG EXCEPTION RAISED (E2)"); + END; + + BEGIN + DECLARE + TYPE I IS ACCESS SUBINT RANGE + GEN_INT'FIRST..SUBINT'LAST; + BEGIN + FAILED ("NO EXCEPTION RAISED (I1)"); + DECLARE + Z : I := NEW SUBINT'(SUBINT'FIRST); + BEGIN + IF NOT EQUAL(INTEGER(Z.ALL),INTEGER(Z.ALL)) + THEN + COMMENT ("DON'T OPTIMIZE Z"); + END IF; + END; + EXCEPTION + WHEN OTHERS => + FAILED ("EXCEPTION RAISED IN WRONG PLACE " & + "(I1)"); + END; + EXCEPTION + WHEN CONSTRAINT_ERROR => + NULL; + WHEN OTHERS => + FAILED ("WRONG EXCEPTION RAISED (I1)"); + END; + + BEGIN + DECLARE + TYPE I IS NEW + SUBINT RANGE SUBINT'FIRST..GEN_INT'LAST; + BEGIN + FAILED ("NO EXCEPTION RAISED (I2)"); + DECLARE + Z : I := I'FIRST; + BEGIN + IF NOT EQUAL(INTEGER(Z),INTEGER(Z)) THEN + COMMENT ("DON'T OPTIMIZE Z"); + END IF; + END; + EXCEPTION + WHEN OTHERS => + FAILED ("EXCEPTION RAISED IN WRONG PLACE " & + "(I2)"); + END; + EXCEPTION + WHEN CONSTRAINT_ERROR => + NULL; + WHEN OTHERS => + FAILED ("WRONG EXCEPTION RAISED (I2)"); + END; + + BEGIN + DECLARE + SUBTYPE I IS SUBINT RANGE A1'RANGE; + BEGIN + FAILED ("NO EXCEPTION RAISED (R1)"); + DECLARE + Z : I := SUBINT'FIRST; + BEGIN + IF NOT EQUAL(INTEGER(Z),INTEGER(Z)) THEN + COMMENT ("DON'T OPTIMIZE Z"); + END IF; + END; + EXCEPTION + WHEN OTHERS => + FAILED ("EXCEPTION RAISED IN WRONG PLACE " & + "(R1)"); + END; + EXCEPTION + WHEN CONSTRAINT_ERROR => + NULL; + WHEN OTHERS => + FAILED ("WRONG EXCEPTION RAISED (R1)"); + END; + + BEGIN + DECLARE + SUBTYPE I IS SUBINT RANGE A2'RANGE; + BEGIN + FAILED ("NO EXCEPTION RAISED (R2)"); + DECLARE + Z : I := 1; + BEGIN + IF NOT EQUAL(INTEGER(Z),INTEGER(Z)) THEN + COMMENT ("DON'T OPTIMIZE Z"); + END IF; + END; + EXCEPTION + WHEN OTHERS => + FAILED ("EXCEPTION RAISED IN WRONG PLACE " & + "(R2)"); + END; + EXCEPTION + WHEN CONSTRAINT_ERROR => + NULL; + WHEN OTHERS => + FAILED ("WRONG EXCEPTION RAISED (R2)"); + END; + END GEN_PACK; + + PACKAGE ENUM_PACK IS NEW GEN_PACK(ENUM, INT); + +BEGIN + RESULT; +END C35003B; diff --git a/gcc-4.9/gcc/testsuite/ada/acats/tests/c3/c35003d.ada b/gcc-4.9/gcc/testsuite/ada/acats/tests/c3/c35003d.ada new file mode 100644 index 000000000..c5241ee80 --- /dev/null +++ b/gcc-4.9/gcc/testsuite/ada/acats/tests/c3/c35003d.ada @@ -0,0 +1,92 @@ +-- C35003D.ADA + +-- Grant of Unlimited Rights +-- +-- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687, +-- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained +-- unlimited rights in the software and documentation contained herein. +-- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making +-- this public release, the Government intends to confer upon all +-- recipients unlimited rights equal to those held by the Government. +-- These rights include rights to use, duplicate, release or disclose the +-- released technical data and computer software in whole or in part, in +-- any manner and for any purpose whatsoever, and to have or permit others +-- to do so. +-- +-- DISCLAIMER +-- +-- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR +-- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED +-- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE +-- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE +-- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A +-- PARTICULAR PURPOSE OF SAID MATERIAL. +--* +-- OBJECTIVE: +-- CHECK THAT CONSTRAINT_ERROR IS RAISED FOR A FLOATING-POINT +-- SUBTYPE INDICATION WHEN THE LOWER OR UPPER BOUND OF A NON-NULL +-- RANGE LIES OUTSIDE THE RANGE OF THE TYPE MARK. + +-- HISTORY: +-- JET 07/11/88 CREATED ORIGINAL TEST. + +WITH REPORT; USE REPORT; + +PROCEDURE C35003D IS + + SUBTYPE FLT1 IS FLOAT RANGE -100.0 .. 100.0; + +BEGIN + TEST ("C35003D", "CHECK THAT CONSTRAINT_ERROR IS RAISED FOR A " & + "FLOATING-POINT SUBTYPE INDICATION WHEN THE " & + "LOWER OR UPPER BOUND OF A NON-NULL RANGE LIES " & + "OUTSIDE THE RANGE OF THE TYPE MARK"); + BEGIN + DECLARE + SUBTYPE F IS FLT1 RANGE 0.0..101.0+FLT1(IDENT_INT(0)); + BEGIN + FAILED ("NO EXCEPTION RAISED (F1)"); + DECLARE + Z : F := 1.0; + BEGIN + IF NOT EQUAL(INTEGER(Z),INTEGER(Z)) THEN + COMMENT ("DON'T OPTIMIZE Z"); + END IF; + END; + EXCEPTION + WHEN OTHERS => + FAILED ("EXCEPTION RAISED IN WRONG PLACE (F1)"); + END; + EXCEPTION + WHEN CONSTRAINT_ERROR => + NULL; + WHEN OTHERS => + FAILED ("WRONG EXCEPTION RAISED (F1)"); + END; + + BEGIN + DECLARE + SUBTYPE F IS FLT1 RANGE -101.0..0.0; + BEGIN + FAILED ("NO EXCEPTION RAISED (F2)"); + DECLARE + Z : F := -1.0; + BEGIN + IF NOT EQUAL(INTEGER(Z),INTEGER(Z)) THEN + COMMENT ("DON'T OPTIMIZE Z"); + END IF; + END; + EXCEPTION + WHEN OTHERS => + FAILED ("EXCEPTION RAISED IN WRONG PLACE (F2)"); + END; + EXCEPTION + WHEN CONSTRAINT_ERROR => + NULL; + WHEN OTHERS => + FAILED ("WRONG EXCEPTION RAISED (F2)"); + END; + + RESULT; + +END C35003D; diff --git a/gcc-4.9/gcc/testsuite/ada/acats/tests/c3/c35102a.ada b/gcc-4.9/gcc/testsuite/ada/acats/tests/c3/c35102a.ada new file mode 100644 index 000000000..a5ca875e4 --- /dev/null +++ b/gcc-4.9/gcc/testsuite/ada/acats/tests/c3/c35102a.ada @@ -0,0 +1,364 @@ +-- C35102A.ADA + +-- Grant of Unlimited Rights +-- +-- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687, +-- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained +-- unlimited rights in the software and documentation contained herein. +-- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making +-- this public release, the Government intends to confer upon all +-- recipients unlimited rights equal to those held by the Government. +-- These rights include rights to use, duplicate, release or disclose the +-- released technical data and computer software in whole or in part, in +-- any manner and for any purpose whatsoever, and to have or permit others +-- to do so. +-- +-- DISCLAIMER +-- +-- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR +-- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED +-- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF 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 ENUMERATION LITERAL BELONGING TO ONE ENUMERATION TYPE +-- MAY BE DECLARED IN ANOTHER ENUMERATION TYPE DEFINITION IN THE SAME +-- DECLARATIVE REGION. + +-- R.WILLIAMS 8/20/86 +-- GMT 6/30/87 MOVED THE CALL TO REPORT.TEST INTO A NEWLY +-- CREATED PACKAGE NAMED SHOW_TEST_HEADER. +-- ADDED CODE FOR MY_PACK AND MY_FTN. + + +WITH REPORT; USE REPORT; +PROCEDURE C35102A IS + + TYPE E1 IS ('A', 'B', 'C', RED, YELLOW, BLUE); + TYPE E2 IS ('A', 'C', RED, BLUE); + + PACKAGE SHOW_TEST_HEADER IS + -- PURPOSE OF THIS PACKAGE: + -- WE WANT THE TEST HEADER INFORMATION TO BE + -- PRINTED BEFORE ANY OF THE PASS/FAIL MESSAGES. + END SHOW_TEST_HEADER; + + PACKAGE BODY SHOW_TEST_HEADER IS + BEGIN + TEST ( "C35102A", + "CHECK THAT AN ENUMERATION LITERAL BELONGING " & + "TO ONE ENUMERATION TYPE MAY BE DECLARED IN " & + "ANOTHER ENUMERATION TYPE DEFINITION IN THE " & + "SAME DECLARATIVE REGION" ); + END SHOW_TEST_HEADER; + + FUNCTION MY_FTN ( E : E1 ) RETURN E2 IS + TYPE ENUM1 IS ('A', 'B', 'C', RED, YELLOW, BLUE); + TYPE ENUM2 IS ('A', 'C', RED, BLUE); + BEGIN + IF ENUM2'SUCC ('A') /= 'C' THEN + FAILED ( "'A' NOT DECLARED CORRECTLY IN ENUM2 " & + "IN MY_FTN - 1" ); + END IF; + + IF ENUM1'POS (RED) /= 3 THEN + FAILED ( "RED NOT DECLARED CORRECTLY IN ENUM1 " & + "IN MY_FTN - 1" ); + END IF; + + RETURN E2'VAL ( IDENT_INT ( E1'POS(E) ) ); + END MY_FTN; + + + PACKAGE MY_PACK IS + END MY_PACK; + + PACKAGE BODY MY_PACK IS + TYPE ENUM1 IS ('A', 'B', 'C', RED, YELLOW, BLUE); + TYPE ENUM2 IS ('A', 'C', RED, BLUE); + BEGIN -- MY_PACK + IF ENUM2'SUCC ('A') /= 'C' THEN + FAILED ( "'A' NOT DECLARED CORRECTLY IN ENUM2 " & + "IN MY_PACK - 1" ); + END IF; + + IF ENUM1'POS (RED) /= 3 THEN + FAILED ( "RED NOT DECLARED CORRECTLY IN ENUM1 " & + "IN MY_PACK - 1" ); + END IF; + END MY_PACK; + + PACKAGE PKG IS + TYPE ENUM1 IS ('A', 'B', 'C', RED, YELLOW, BLUE); + TYPE ENUM2 IS ('A', 'C', RED, BLUE); + + END PKG; + + PACKAGE BODY PKG IS + BEGIN + IF ENUM2'SUCC ('A') /= 'C' THEN + FAILED ( "'A' NOT DECLARED CORRECTLY IN ENUM2 " & + "IN PKG - 1" ); + END IF; + + IF ENUM1'POS (RED) /= 3 THEN + FAILED ( "RED NOT DECLARED CORRECTLY IN ENUM1 " & + "IN PKG - 1" ); + END IF; + END PKG; + + PACKAGE PRIV IS + TYPE ENUM1 IS PRIVATE; + TYPE ENUM2 IS PRIVATE; + + FUNCTION FE1 (E : E1) RETURN ENUM1; + + FUNCTION FE2 (E : E2) RETURN ENUM2; + + PRIVATE + TYPE ENUM1 IS ('A', 'B', 'C', RED, YELLOW, BLUE); + TYPE ENUM2 IS ('A', 'C', RED, BLUE); + + END PRIV; + + PACKAGE BODY PRIV IS + FUNCTION FE1 (E : E1) RETURN ENUM1 IS + BEGIN + RETURN ENUM1'VAL (IDENT_INT (E1'POS (E))); + END FE1; + + FUNCTION FE2 (E : E2) RETURN ENUM2 IS + BEGIN + RETURN ENUM2'VAL (IDENT_INT (E2'POS (E))); + END FE2; + + BEGIN + IF ENUM2'SUCC ('A') /= 'C' THEN + FAILED ( "'A' NOT DECLARED CORRECTLY IN ENUM2 " & + "IN PRIV - 1" ); + END IF; + + IF ENUM1'POS (RED) /= 3 THEN + FAILED ( "RED NOT DECLARED CORRECTLY IN ENUM1 " & + "IN PRIV - 1" ); + END IF; + END PRIV; + + PACKAGE LPRIV IS + TYPE ENUM1 IS LIMITED PRIVATE; + TYPE ENUM2 IS LIMITED PRIVATE; + + FUNCTION FE1 (E : E1) RETURN ENUM1; + + FUNCTION FE2 (E : E2) RETURN ENUM2; + + FUNCTION EQUALS (A, B : ENUM1) RETURN BOOLEAN; + + FUNCTION EQUALS (A, B : ENUM2) RETURN BOOLEAN; + + PRIVATE + TYPE ENUM1 IS ('A', 'B', 'C', RED, YELLOW, BLUE); + TYPE ENUM2 IS ('A', 'C', RED, BLUE); + + END LPRIV; + + PACKAGE BODY LPRIV IS + FUNCTION FE1 (E : E1) RETURN ENUM1 IS + BEGIN + RETURN ENUM1'VAL (IDENT_INT (E1'POS (E))); + END FE1; + + FUNCTION FE2 (E : E2) RETURN ENUM2 IS + BEGIN + RETURN ENUM2'VAL (IDENT_INT (E2'POS (E))); + END FE2; + + FUNCTION EQUALS (A, B : ENUM1) RETURN BOOLEAN IS + BEGIN + IF A = B THEN + RETURN TRUE; + ELSE + RETURN FALSE; + END IF; + END EQUALS; + + FUNCTION EQUALS (A, B : ENUM2) RETURN BOOLEAN IS + BEGIN + IF A = B THEN + RETURN TRUE; + ELSE + RETURN FALSE; + END IF; + END EQUALS; + BEGIN + IF ENUM2'SUCC ('A') /= 'C' THEN + FAILED ( "'A' NOT DECLARED CORRECTLY IN ENUM2 " & + "IN LPRIV - 1" ); + END IF; + + IF ENUM1'POS (RED) /= 3 THEN + FAILED ( "RED NOT DECLARED CORRECTLY IN ENUM1 " & + "IN LPRIV - 2" ); + END IF; + END LPRIV; + + TASK T1; + + TASK BODY T1 IS + TYPE ENUM1 IS ('A', 'B', 'C', RED, YELLOW, BLUE); + TYPE ENUM2 IS ('A', 'C', RED, BLUE); + + BEGIN + IF ENUM2'SUCC ('A') /= 'C' THEN + FAILED ( "'A' NOT DECLARED CORRECTLY IN ENUM2 " & + "IN T1" ); + END IF; + + IF ENUM1'POS (RED) /= 3 THEN + FAILED ( "RED NOT DECLARED CORRECTLY IN ENUM1 " & + "IN T1" ); + END IF; + END T1; + + TASK T2 IS + ENTRY E; + END T2; + + TASK BODY T2 IS + BEGIN + ACCEPT E DO + DECLARE + TYPE ENUM1 IS ('A', 'B', 'C', RED, YELLOW, BLUE); + TYPE ENUM2 IS ('A', 'C', RED, BLUE); + + BEGIN + IF ENUM2'SUCC ('A') /= 'C' THEN + FAILED ( "'A' NOT DECLARED CORRECTLY IN ENUM2 " & + "IN T2.E" ); + END IF; + + IF ENUM1'POS (RED) /= 3 THEN + FAILED ( "RED NOT DECLARED CORRECTLY IN " & + "ENUM1 IN T2.E" ); + END IF; + END; + END E; + END T2; + + GENERIC + PROCEDURE GP1; + + PROCEDURE GP1 IS + TYPE ENUM1 IS ('A', 'B', 'C', RED, YELLOW, BLUE); + TYPE ENUM2 IS ('A', 'C', RED, BLUE); + + BEGIN + IF ENUM2'SUCC ('A') /= 'C' THEN + FAILED ( "'A' NOT DECLARED CORRECTLY IN ENUM2 " & + "IN GP1" ); + END IF; + + IF ENUM1'POS (RED) /= 3 THEN + FAILED ( "RED NOT DECLARED CORRECTLY IN ENUM1 " & + "IN GP1" ); + END IF; + END GP1; + + GENERIC + TYPE E1 IS (<>); + TYPE E2 IS (<>); + PROCEDURE GP2; + + PROCEDURE GP2 IS + BEGIN + IF E2'SUCC (E2'VALUE ("'A'")) /= E2'VALUE ("'C'") THEN + FAILED ( "'A' NOT DECLARED CORRECTLY IN E2 " & + "IN GP2" ); + END IF; + + IF E1'POS (E1'VALUE ("RED")) /= 3 THEN + FAILED ( "RED NOT DECLARED CORRECTLY IN E1 " & + "IN GP2" ); + END IF; + END GP2; + + PROCEDURE NEWGP1 IS NEW GP1; + PROCEDURE NEWGP2 IS NEW GP2 (E1, E2); + +BEGIN + + DECLARE + TYPE ENUM1 IS ('A', 'B', 'C', RED, YELLOW, BLUE); + TYPE ENUM2 IS ('A', 'C', RED, BLUE); + + BEGIN + IF ENUM2'SUCC ('A') /= 'C' THEN + FAILED ( "'A' NOT DECLARED CORRECTLY IN ENUM2 " & + "IN BLOCK" ); + END IF; + + IF ENUM1'POS (RED) /= 3 THEN + FAILED ( "RED NOT DECLARED CORRECTLY IN ENUM1 " & + "IN BLOCK" ); + END IF; + END; + + DECLARE + USE PKG; + BEGIN + IF ENUM2'SUCC ('A') /= 'C' THEN + FAILED ( "'A' NOT DECLARED CORRECTLY IN ENUM2 " & + "IN PKG - 2" ); + END IF; + + IF ENUM1'POS (RED) /= 3 THEN + FAILED ( "RED NOT DECLARED CORRECTLY IN ENUM1 " & + "IN PKG - 2" ); + END IF; + END; + + DECLARE + USE PRIV; + BEGIN + IF FE2 (E2'SUCC('A')) /= FE2 ('C') THEN + FAILED ( "'A' NOT DECLARED CORRECTLY IN ENUM2 " & + "IN PRIV - 2" ); + END IF; + + IF FE1 (RED) /= FE1 (E1'VAL (3)) THEN + FAILED ( "RED NOT DECLARED CORRECTLY IN ENUM1 " & + "IN PRIV - 2" ); + END IF; + END; + + DECLARE + USE LPRIV; + BEGIN + IF NOT EQUALS (FE2 (E2'SUCC('A')), FE2 ('C')) THEN + FAILED ( "'A' NOT DECLARED CORRECTLY IN ENUM2 " & + "IN LPRIV - 2" ); + END IF; + + IF NOT EQUALS (FE1 (RED), FE1 (E1'VAL (3))) THEN + FAILED ( "RED NOT DECLARED CORRECTLY IN ENUM1 " & + "IN LPRIV - 2" ); + END IF; + END; + + BEGIN + IF E2'SUCC ('A') /= 'C' THEN + FAILED ( "'A' NOT DECLARED CORRECTLY IN E2" ); + END IF; + + IF E1'POS (RED) /= 3 THEN + FAILED ( "RED NOT DECLARED CORRECTLY IN E1" ); + END IF; + END; + + NEWGP1; + NEWGP2; + T2.E; + + RESULT; +END C35102A; diff --git a/gcc-4.9/gcc/testsuite/ada/acats/tests/c3/c354002.a b/gcc-4.9/gcc/testsuite/ada/acats/tests/c3/c354002.a new file mode 100644 index 000000000..3129182b7 --- /dev/null +++ b/gcc-4.9/gcc/testsuite/ada/acats/tests/c3/c354002.a @@ -0,0 +1,335 @@ +-- +-- C354002.A +-- +-- Grant of Unlimited Rights +-- +-- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687, +-- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained +-- unlimited rights in the software and documentation contained herein. +-- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making +-- this public release, the Government intends to confer upon all +-- recipients unlimited rights equal to those held by the Government. +-- These rights include rights to use, duplicate, release or disclose the +-- released technical data and computer software in whole or in part, in +-- any manner and for any purpose whatsoever, and to have or permit others +-- to do so. +-- +-- DISCLAIMER +-- +-- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR +-- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED +-- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE +-- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE +-- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A +-- PARTICULAR PURPOSE OF SAID MATERIAL. +--* +-- +-- OBJECTIVE: +-- Check that the attributes of modular types yield +-- correct values/results. The attributes checked are: +-- +-- First, Last, Range, Base, Min, Max, Succ, Pred, +-- Image, Width, Value, Pos, and Val +-- +-- TEST DESCRIPTION: +-- This test defines several modular types. One type defined at +-- each of System.Max_Binary_Modulus, System.Max_Nonbinary_Modulus, +-- a power of two half that of System.Max_Binary_Modulus, one less +-- than that power of two; one more than that power of two, two +-- less than a (large) power of two. For each of these types, +-- determine the correct operation of the following attributes: +-- +-- First, Last, Range, Base, Min, Max, Succ, Pred, Image, Width, +-- Value, Pos, Val, and Modulus +-- +-- The attributes Wide_Image and Wide_Value are deferred to C354003. +-- +-- +-- +-- CHANGE HISTORY: +-- 08 SEP 94 SAIC Initial version +-- 17 NOV 94 SAIC Revised version +-- 13 DEC 94 SAIC split off Wide_String attributes into C354003 +-- 06 JAN 95 SAIC Promoted to next release +-- 19 APR 95 SAIC Revised in accord with reviewer comments +-- 27 JAN 96 SAIC Eliminated 32/64 bit potential conflict for 2.1 +-- +--! + +with Report; +with System; +with TCTouch; +procedure C354002 is + + function ID(Local_Value: Integer) return Integer renames Report.Ident_Int; + function ID(Local_Value: String) return String renames Report.Ident_Str; + + Power_2_Bits : constant := System.Storage_Unit; + Half_Max_Binary_Value : constant := System.Max_Binary_Modulus / 2; + + type Max_Binary is mod System.Max_Binary_Modulus; + type Max_NonBinary is mod System.Max_Nonbinary_Modulus; + type Half_Max_Binary is mod Half_Max_Binary_Value; + + type Medium is mod 2048; + type Medium_Plus is mod 2042; + type Medium_Minus is mod 2111; + + type Small is mod 2; + type Finger is mod 5; + + MBL : constant := Max_NonBinary'Last; + MNBM : constant := Max_NonBinary'Modulus; + + Ones_Complement_Permission : constant Boolean := MBL = MNBM; + + type Finger_Id is (Thumb, Index, Middle, Ring, Pinkie); + + subtype Midrange is Medium_Minus range 222 .. 1111; + +-- a few numbers for testing purposes + Max_Binary_Mod_Over_3 : constant := Max_Binary'Modulus / 3; + Max_NonBinary_Mod_Over_4 : constant := Max_NonBinary'Modulus / 4; + System_Max_Bin_Mod_Pred : constant := System.Max_Binary_Modulus - 1; + System_Max_NonBin_Mod_Pred : constant := System.Max_Nonbinary_Modulus - 1; + Half_Max_Bin_Value_Pred : constant := Half_Max_Binary_Value - 1; + + AMB, BMB : Max_Binary; + AHMB, BHMB : Half_Max_Binary; + AM, BM : Medium; + AMP, BMP : Medium_Plus; + AMM, BMM : Medium_Minus; + AS, BS : Small; + AF, BF : Finger; + + TC_Pass_Case : Boolean := True; + + procedure Value_Fault( S: String ) is + -- check 'Value for failure modes + begin + -- the evaluation of the 'Value expression should raise C_E + TCTouch.Assert_Not( Midrange'Value(S) = 0, "Value_Fault" ); + if Midrange'Value(S) not in Midrange'Base then + Report.Failed("'Value(" & S & ") raised no exception"); + end if; + exception + when Constraint_Error => null; -- expected case + when others => + Report.Failed("'Value(" & S & ") raised wrong exception"); + end Value_Fault; + +begin -- Main test procedure. + + Report.Test ("C354002", "Check attributes of modular types" ); + +-- Base + TCTouch.Assert( Midrange'Base'First = 0, "Midrange'Base'First" ); + TCTouch.Assert( Midrange'Base'Last = Medium_Minus'Last, + "Midrange'Base'Last" ); + +-- First + TCTouch.Assert( Max_Binary'First = 0, "Max_Binary'First" ); + TCTouch.Assert( Max_NonBinary'First = 0, "Max_NonBinary'First" ); + TCTouch.Assert( Half_Max_Binary'First = 0, "Half_Max_Binary'First" ); + + TCTouch.Assert( Medium'First = Medium(ID(0)), "Medium'First" ); + TCTouch.Assert( Medium_Plus'First = Medium_Plus(ID(0)), + "Medium_Plus'First" ); + TCTouch.Assert( Medium_Minus'First = Medium_Minus(ID(0)), + "Medium_Minus'First" ); + + TCTouch.Assert( Small'First = Small(ID(0)), "Small'First" ); + TCTouch.Assert( Finger'First = Finger(ID(0)), "Finger'First" ); + TCTouch.Assert( Midrange'First = Midrange(ID(222)), + "Midrange'First" ); + +-- Image + TCTouch.Assert( Half_Max_Binary'Image(255) = " 255", + "Half_Max_Binary'Image" ); + TCTouch.Assert( Medium'Image(0) = ID(" 0"), "Medium'Image" ); + TCTouch.Assert( Medium_Plus'Image(Medium_Plus'Last) = " 2041", + "Medium_Plus'Image" ); + TCTouch.Assert( Medium_Minus'Image(Medium_Minus(ID(1024))) = " 1024", + "Medium_Minus'Image" ); + TCTouch.Assert( Small'Image(Small(ID(1))) = " 1", "Small'Image" ); + TCTouch.Assert( Midrange'Image(Midrange(ID(333))) = " 333", + "Midrange'Image" ); + +-- Last + TCTouch.Assert( Max_Binary'Last = System_Max_Bin_Mod_Pred, + "Max_Binary'Last"); + if Ones_Complement_Permission then + TCTouch.Assert( Max_NonBinary'Last >= System_Max_NonBin_Mod_Pred, + "Max_NonBinary'Last (ones comp)"); + else + TCTouch.Assert( Max_NonBinary'Last = System_Max_NonBin_Mod_Pred, + "Max_NonBinary'Last"); + end if; + TCTouch.Assert( Half_Max_Binary'Last = Half_Max_Bin_Value_Pred, + "Half_Max_Binary'Last"); + + TCTouch.Assert( Medium'Last = Medium(ID(2047)), "Medium'Last"); + TCTouch.Assert( Medium_Plus'Last = Medium_Plus(ID(2041)), + "Medium_Plus'Last"); + TCTouch.Assert( Medium_Minus'Last = Medium_Minus(ID(2110)), + "Medium_Minus'Last"); + TCTouch.Assert( Small'Last = Small(ID(1)), "Small'Last"); + TCTouch.Assert( Finger'Last = Finger(ID(4)), "Finger'Last"); + TCTouch.Assert( Midrange'Last = Midrange(ID(1111)), "Midrange'Last"); + +-- Max + TCTouch.Assert( Max_Binary'Max(Power_2_Bits, Max_Binary'Last) + = Max_Binary'Last, "Max_Binary'Max"); + TCTouch.Assert( Max_NonBinary'Max(100,2000) = 2000, "Max_NonBinary'Max"); + TCTouch.Assert( Half_Max_Binary'Max(123,456) = 456, + "Half_Max_Binary'Max"); + + TCTouch.Assert( Medium'Max(0,2040) = 2040, "Medium'Max"); + TCTouch.Assert( Medium_Plus'Max(0,1) = 1, "Medium_Plus'Max"); + TCTouch.Assert( Medium_Minus'Max(2001,1995) = 2001, "Medium_Minus'Max"); + TCTouch.Assert( Small'Max(1,0) = 1, "Small'Max"); + TCTouch.Assert( Finger'Max(Finger'Last+1,4) = 4, "Finger'Max"); + TCTouch.Assert( Midrange'Max(Midrange'First+1,222) = Midrange'First+1, + "Midrange'Max"); + +-- Min + TCTouch.Assert( Max_Binary'Min(Power_2_Bits, Max_Binary'Last) + = Power_2_Bits, "Max_Binary'Min"); + TCTouch.Assert( Max_NonBinary'Min(100,2000) = 100, "Max_NonBinary'Min"); + TCTouch.Assert( Half_Max_Binary'Min(123,456) = 123, + "Half_Max_Binary'Min"); + + TCTouch.Assert( Medium'Min(0,Medium(ID(2040))) = 0, "Medium'Min"); + TCTouch.Assert( Medium_Plus'Min(0,1) = 0, "Medium_Plus'Min"); + TCTouch.Assert( Medium_Minus'Min(2001,1995) = 1995, "Medium_Minus'Min"); + TCTouch.Assert( Small'Min(1,0) = 0, "Small'Min"); + TCTouch.Assert( Finger'Min(Finger'Last+1,4) /= 4, "Finger'Min"); + TCTouch.Assert( Midrange'Min(Midrange'First+1,222) = 222, + "Midrange'Min"); +-- Modulus + TCTouch.Assert( Max_Binary'Modulus = System.Max_Binary_Modulus, + "Max_Binary'Modulus"); + TCTouch.Assert( Max_NonBinary'Modulus = System.Max_Nonbinary_Modulus, + "Max_NonBinary'Modulus"); + TCTouch.Assert( Half_Max_Binary'Modulus = Half_Max_Binary_Value, + "Half_Max_Binary'Modulus"); + + TCTouch.Assert( Medium'Modulus = 2048, "Medium'Modulus"); + TCTouch.Assert( Medium_Plus'Modulus = 2042, "Medium_Plus'Modulus"); + TCTouch.Assert( Medium_Minus'Modulus = 2111, "Medium_Minus'Modulus"); + TCTouch.Assert( Small'Modulus = 2, "Small'Modulus"); + TCTouch.Assert( Finger'Modulus = 5, "Finger'Modulus"); + TCTouch.Assert( Midrange'Modulus = ID(2111), "Midrange'Modulus"); + +-- Pos + declare + Int : Natural := 222; + begin + for I in Midrange loop + TC_Pass_Case := TC_Pass_Case and Midrange'Pos(I) = Int; + + Int := Int +1; + end loop; + end; + + TCTouch.Assert( TC_Pass_Case, "Midrange'Pos"); + +-- Pred + TCTouch.Assert( Max_Binary'Pred(0) = System_Max_Bin_Mod_Pred, + "Max_Binary'Pred(0)"); + if Ones_Complement_Permission then + TCTouch.Assert( Max_NonBinary'Pred(0) >= System_Max_NonBin_Mod_Pred, + "Max_NonBinary'Pred(0) (ones comp)"); + else + TCTouch.Assert( Max_NonBinary'Pred(0) = System_Max_NonBin_Mod_Pred, + "Max_NonBinary'Pred(0)"); + end if; + TCTouch.Assert( Half_Max_Binary'Pred(0) = Half_Max_Bin_Value_Pred, + "Half_Max_Binary'Pred(0)"); + + TCTouch.Assert( Medium'Pred(Medium(ID(0))) = 2047, "Medium'Pred(0)"); + TCTouch.Assert( Medium_Plus'Pred(0) = 2041, "Medium_Plus'Pred(0)"); + TCTouch.Assert( Medium_Minus'Pred(0) = 2110, "Medium_Minus'Pred(0)"); + TCTouch.Assert( Small'Pred(0) = 1, "Small'Pred(0)"); + TCTouch.Assert( Finger'Pred(Finger(ID(0))) = 4, "Finger'Pred(0)"); + TCTouch.Assert( Midrange'Pred(222) = 221, "Midrange'Pred('First)"); + +-- Range + for I in Midrange'Range loop + if I not in Midrange then + Report.Failed("Midrange loop test"); + end if; + end loop; + for I in Medium'Range loop + if I not in Medium then + Report.Failed("Medium loop test"); + end if; + end loop; + for I in Medium_Minus'Range loop + if I not in 0..2110 then + Report.Failed("Medium loop test"); + end if; + end loop; + +-- Succ + TCTouch.Assert( Max_Binary'Succ(System_Max_Bin_Mod_Pred) = 0, + "Max_Binary'Succ('Last)"); + if Ones_Complement_Permission then + TCTouch.Assert( (Max_NonBinary'Succ(System_Max_NonBin_Mod_Pred) = 0) + or (Max_NonBinary'Succ(System_Max_NonBin_Mod_Pred) + = Max_NonBinary'Last), + "Max_NonBinary'Succ('Last) (ones comp)"); + else + TCTouch.Assert( Max_NonBinary'Succ(System_Max_NonBin_Mod_Pred) = 0, + "Max_NonBinary'Succ('Last)"); + end if; + TCTouch.Assert( Half_Max_Binary'Succ(Half_Max_Bin_Value_Pred) = 0, + "Half_Max_Binary'Succ('Last)"); + + TCTouch.Assert( Medium'Succ(2047) = 0, "Medium'Succ('Last)"); + TCTouch.Assert( Medium_Plus'Succ(2041) = 0, "Medium_Plus'Succ('Last)"); + TCTouch.Assert( Medium_Minus'Succ(2110) = 0, "Medium_Minus'Succ('Last)"); + TCTouch.Assert( Small'Succ(1) = 0, "Small'Succ('Last)"); + TCTouch.Assert( Finger'Succ(4) = 0, "Finger'Succ('Last)"); + TCTouch.Assert( Midrange'Succ(Midrange(ID(1111))) = 1112, + "Midrange'Succ('Last)"); + +-- Val + for I in Natural range ID(222)..ID(1111) loop + TCTouch.Assert( Midrange'Val(I) = Medium_Minus(I), "Midrange'Val"); + end loop; + +-- Value + + TCTouch.Assert( Half_Max_Binary'Value("255") = 255, + "Half_Max_Binary'Value" ); + + TCTouch.Assert( Medium'Value(" 1e2") = 100, "Medium'Value(""1e2"")" ); + TCTouch.Assert( Medium'Value(" 0 ") = 0, "Medium'Value" ); + TCTouch.Assert( Medium_Plus'Value(ID("2041")) = 2041, + "Medium_Plus'Value" ); + TCTouch.Assert( Medium_Minus'Value(ID("+10_24")) = 1024, + "Medium_Minus'Value" ); + + TCTouch.Assert( Small'Value("+1") = 1, "Small'Value" ); + TCTouch.Assert( Midrange'Value(ID("333")) = 333, "Midrange'Value" ); + TCTouch.Assert( Midrange'Value("1E3") = 1000, + "Midrange'Value(""1E3"")" ); + + Value_Fault( "bad input" ); + Value_Fault( "-333" ); + Value_Fault( "9999" ); + Value_Fault( ".1" ); + Value_Fault( "1e-1" ); + +-- Width + TCTouch.Assert( Medium'Width = 5, "Medium'Width"); + TCTouch.Assert( Medium_Plus'Width = 5, "Medium_Plus'Width"); + TCTouch.Assert( Medium_Minus'Width = 5, "Medium_Minus'Width"); + TCTouch.Assert( Small'Width = 2, "Small'Width"); + TCTouch.Assert( Finger'Width = 2, "Finger'Width"); + TCTouch.Assert( Midrange'Width = 5, "Midrange'Width"); + + Report.Result; + +end C354002; diff --git a/gcc-4.9/gcc/testsuite/ada/acats/tests/c3/c354003.a b/gcc-4.9/gcc/testsuite/ada/acats/tests/c3/c354003.a new file mode 100644 index 000000000..1f607a7e6 --- /dev/null +++ b/gcc-4.9/gcc/testsuite/ada/acats/tests/c3/c354003.a @@ -0,0 +1,211 @@ +-- C354003.A +-- +-- Grant of Unlimited Rights +-- +-- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687, +-- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained +-- unlimited rights in the software and documentation contained herein. +-- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making +-- this public release, the Government intends to confer upon all +-- recipients unlimited rights equal to those held by the Government. +-- These rights include rights to use, duplicate, release or disclose the +-- released technical data and computer software in whole or in part, in +-- any manner and for any purpose whatsoever, and to have or permit others +-- to do so. +-- +-- DISCLAIMER +-- +-- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR +-- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED +-- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE +-- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE +-- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A +-- PARTICULAR PURPOSE OF SAID MATERIAL. +--* +-- +-- OBJECTIVE: +-- Check that the Wide_String attributes of modular types yield +-- correct values/results. The attributes checked are: +-- +-- Wide_Image +-- Wide_Value +-- +-- TEST DESCRIPTION: +-- This test is split from C354002. It tests only the attributes: +-- +-- Wide_Image, Wide_Value +-- +-- This test defines several modular types. One type defined at +-- each of System.Max_Binary_Modulus, System.Max_Nonbinary_Modulus, +-- a power of two half that of System.Max_Binary_Modulus, one less +-- than that power of two; one more than that power of two, two +-- less than a (large) power of two. For each of these types, +-- determine the correct operation of the Wide_String attributes. +-- +-- +-- CHANGE HISTORY: +-- 13 DEC 94 SAIC Initial version +-- 06 JAN 94 SAIC Promoted to future release +-- 19 APR 95 SAIC Revised in accord with reviewer comments +-- 01 DEC 95 SAIC Corrected for 2.0.1 +-- 27 JAN 96 SAIC Eliminated potential 32/64 bit conflict for 2.1 +-- 24 FEB 97 PWB.CTA Corrected out-of-range value +--! + +with Report; +with System; +with TCTouch; +with Ada.Characters.Handling; +procedure C354003 is + + function ID(Local_Value: Integer) return Integer renames Report.Ident_Int; + function ID(Local_Value: String) return String renames Report.Ident_Str; + + function ID(Local_Value: String) return Wide_String is + begin + return Ada.Characters.Handling.To_Wide_String( ID( Local_Value ) ); + end ID; + + Half_Max_Binary_Value : constant := System.Max_Binary_Modulus / 2; + + type Max_Binary is mod System.Max_Binary_Modulus; + type Max_NonBinary is mod System.Max_Nonbinary_Modulus; + type Half_Max_Binary is mod Half_Max_Binary_Value; + + type Medium is mod 2048; + type Medium_Plus is mod 2042; + type Medium_Minus is mod 2111; + + type Small is mod 2; + type Finger is mod 5; + + type Finger_Id is (Thumb, Index, Middle, Ring, Pinkie); + + subtype Midrange is Medium_Minus range 222 .. 1111; + + AMB, BMB : Max_Binary; + AHMB, BHMB : Half_Max_Binary; + AM, BM : Medium; + AMP, BMP : Medium_Plus; + AMM, BMM : Medium_Minus; + AS, BS : Small; + AF, BF : Finger; + + procedure Wide_Value_Fault( S: Wide_String ) is + -- check 'Wide_Value for failure modes + begin + -- the evaluation of the 'Wide_Value expression should raise C_E + TCTouch.Assert_Not( Midrange'Wide_Value(S) = 0, "Wide_Value_Fault" ); + if Midrange'Wide_Value(S) not in Midrange'Base then + Report.Failed("'Wide_Value raised no exception"); + end if; + exception + when Constraint_Error => null; -- expected case + when others => + Report.Failed("'Wide_Value raised wrong exception"); + end Wide_Value_Fault; + + + The_Cap, The_Toe : Natural; + + procedure Check_Non_Static_Cases( Lower_Bound,Upper_Bound : Medium ) is + subtype Non_Static is Medium range Lower_Bound..Upper_Bound; + begin + -- First, Last, Range, Min, Max, Succ, Pred, Pos, and Val + + TCTouch.Assert( Non_Static'First = Medium(The_Toe), "Non_Static'First" ); + TCTouch.Assert( Non_Static'Last = Non_Static(The_Cap), + "Non_Static'Last" ); + TCTouch.Assert( Non_Static(The_Cap/2) in Non_Static'Range, + "Non_Static'Range" ); + TCTouch.Assert( Non_Static'Min(Medium(Report.Ident_Int(100)), + Medium(Report.Ident_Int(200))) = 100, + "Non_Static'Min" ); + TCTouch.Assert( Non_Static'Max(Medium(Report.Ident_Int(100)), + Medium(Report.Ident_Int(200))) = 200, + "Non_Static'Max" ); + TCTouch.Assert( Non_Static'Succ(Non_Static(The_Cap)) + = Medium'Succ(Upper_Bound), + "Non_Static'Succ" ); + TCTouch.Assert( Non_Static'Pred(Medium(Report.Ident_Int(The_Cap))) + = Non_Static(Report.Ident_Int(The_Cap-1)), + "Non_Static'Pred" ); + TCTouch.Assert( Non_Static'Pos(Upper_Bound) = Non_Static(The_Cap), + "Non_Static'Pos" ); + TCTouch.Assert( Non_Static'Val(Non_Static(The_Cap)) = Upper_Bound, + "Non_Static'Val" ); + + end Check_Non_Static_Cases; + + +begin -- Main test procedure. + + Report.Test ("C354003", "Check Wide_String attributes of modular types" ); + + Wide_Strings_Needed: declare + + Max_Bin_Mod_Div_3 : constant := Max_Binary'Modulus/3; + Max_Non_Mod_Div_4 : constant := Max_NonBinary'Modulus/4; + + begin + +-- Wide_Image + + TCTouch.Assert( Half_Max_Binary'Wide_Image(255) = " 255", + "Half_Max_Binary'Wide_Image" ); + + TCTouch.Assert( Medium'Wide_Image(0) = " 0", "Medium'Wide_Image" ); + + TCTouch.Assert( Medium_Plus'Wide_Image(Medium_Plus'Last) = " 2041", + "Medium_Plus'Wide_Image" ); + + TCTouch.Assert( Medium_Minus'Wide_Image(Medium_Minus(ID(1024))) = " 1024", + "Medium_Minus'Wide_Image" ); + + TCTouch.Assert( Small'Wide_Image(1) = " 1", "Small'Wide_Image" ); + + TCTouch.Assert( Midrange'Wide_Image(Midrange(ID(333))) = " 333", + "Midrange'Wide_Image" ); + +-- Wide_Value + + TCTouch.Assert( Half_Max_Binary'Wide_Value("255") = 255, + "Half_Max_Binary'Wide_Value" ); + + TCTouch.Assert( Medium'Wide_Value(" 0 ") = 0, "Medium'Wide_Value" ); + + TCTouch.Assert( Medium_Plus'Wide_Value(ID("2041")) = Medium_Plus'Last, + "Medium_Plus'Wide_Value" ); + + TCTouch.Assert( Medium_Minus'Wide_Value("+1_4 ") = 14, + "Medium_Minus'Wide_Value" ); + + TCTouch.Assert( Small'Wide_Value("+1") = 1, "Small'Wide_Value" ); + + TCTouch.Assert( Midrange'Wide_Value(ID("333")) = 333, + "Midrange'Wide_Value" ); + + TCTouch.Assert( Midrange'Wide_Value(ID("1E3")) = 1000, + "Midrange'Wide_Value(""1E3"")" ); + + Wide_Value_Fault( "bad input" ); + Wide_Value_Fault( "-333" ); + Wide_Value_Fault( "9999" ); + Wide_Value_Fault( ".1" ); + Wide_Value_Fault( "1e-1" ); + + end Wide_Strings_Needed; + + The_Toe := Report.Ident_Int(25); + The_Cap := Report.Ident_Int(256); + Check_Non_Static_Cases( Medium(Report.Ident_Int(The_Toe)), + Medium(Report.Ident_Int(The_Cap)) ); + + The_Toe := Report.Ident_Int(40); + The_Cap := Report.Ident_Int(2047); + Check_Non_Static_Cases( Medium(Report.Ident_Int(The_Toe)), + Medium(Report.Ident_Int(The_Cap)) ); + + Report.Result; + +end C354003; diff --git a/gcc-4.9/gcc/testsuite/ada/acats/tests/c3/c35502a.ada b/gcc-4.9/gcc/testsuite/ada/acats/tests/c3/c35502a.ada new file mode 100644 index 000000000..ffb819046 --- /dev/null +++ b/gcc-4.9/gcc/testsuite/ada/acats/tests/c3/c35502a.ada @@ -0,0 +1,71 @@ +-- C35502A.ADA + +-- Grant of Unlimited Rights +-- +-- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687, +-- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained +-- unlimited rights in the software and documentation contained herein. +-- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making +-- this public release, the Government intends to confer upon all +-- recipients unlimited rights equal to those held by the Government. +-- These rights include rights to use, duplicate, release or disclose the +-- released technical data and computer software in whole or in part, in +-- any manner and for any purpose whatsoever, and to have or permit others +-- to do so. +-- +-- DISCLAIMER +-- +-- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR +-- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED +-- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF 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 ATTRIBUTE 'WIDTH' YIELDS THE CORRECT RESULTS +-- WHEN THE PREFIX IS AN ENUMERATION TYPE OTHER THAN A BOOLEAN OR +-- A CHARACTER TYPE. + +-- RJW 5/05/86 + +WITH REPORT; USE REPORT; + +PROCEDURE C35502A IS + +BEGIN + + TEST( "C35502A" , "CHECK THAT THE ATTRIBUTE 'WIDTH' YIELDS " & + "THE CORRECT RESULTS WHEN THE PREFIX " & + "IS AN ENUMERATION TYPE OTHER THAN " & + "A BOOLEAN OR A CHARACTER TYPE" ); + + DECLARE + TYPE ENUM IS (A, BC, ABC, A_B_C, ABCD); + + SUBTYPE SUBENUM IS ENUM RANGE A .. ABC; + SUBTYPE NOENUM IS ENUM RANGE ABC .. A; + + TYPE NEWENUM IS NEW ENUM; + + BEGIN + + IF ENUM'WIDTH /= IDENT_INT(5) THEN + FAILED( "INCORRECT WIDTH FOR ENUM" ); + END IF; + + IF NEWENUM'WIDTH /= IDENT_INT(5) THEN + FAILED( "INCORRECT WIDTH FOR NEWENUM" ); + END IF; + + IF SUBENUM'WIDTH /= IDENT_INT(3) THEN + FAILED( "INCORRECT WIDTH FOR SUBENUM" ); + END IF; + + IF NOENUM'WIDTH /= IDENT_INT(0) THEN + FAILED( "INCORRECT WIDTH FOR NOENUM" ); + END IF; + + END; + + RESULT; +END C35502A; diff --git a/gcc-4.9/gcc/testsuite/ada/acats/tests/c3/c35502b.ada b/gcc-4.9/gcc/testsuite/ada/acats/tests/c3/c35502b.ada new file mode 100644 index 000000000..aff813514 --- /dev/null +++ b/gcc-4.9/gcc/testsuite/ada/acats/tests/c3/c35502b.ada @@ -0,0 +1,81 @@ +-- C35502B.ADA + +-- Grant of Unlimited Rights +-- +-- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687, +-- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained +-- unlimited rights in the software and documentation contained herein. +-- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making +-- this public release, the Government intends to confer upon all +-- recipients unlimited rights equal to those held by the Government. +-- These rights include rights to use, duplicate, release or disclose the +-- released technical data and computer software in whole or in part, in +-- any manner and for any purpose whatsoever, and to have or permit others +-- to do so. +-- +-- DISCLAIMER +-- +-- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR +-- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED +-- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF 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 ATTRIBUTE 'WIDTH' YIELDS THE CORRECT RESULTS +-- WHEN THE PREFIX IS A GENERIC FORMAL DISCRETE TYPE WHOSE ACTUAL +-- PARAMETER IS AN ENUMERATION TYPE OTHER THAN A BOOLEAN OR CHARACTER +-- TYPE. + +-- RJW 5/05/86 + +WITH REPORT; USE REPORT; + +PROCEDURE C35502B IS + +BEGIN + + TEST( "C35502B" , "CHECK THAT THE ATTRIBUTE 'WIDTH' YIELDS " & + "THE CORRECT RESULTS WHEN THE PREFIX " & + "IS A GENERIC FORMAL DISCRETE TYPE " & + "WHOSE ACTUAL PARAMETER IS AN ENUMERATION " & + "TYPE" ); + + DECLARE + TYPE ENUM IS (A, BC, ABC, A_B_C, ABCD); + SUBTYPE SUBENUM IS ENUM RANGE A .. ABC; + SUBTYPE NOENUM IS ENUM RANGE ABC .. A; + + TYPE NEWENUM IS NEW ENUM; + + GENERIC + TYPE E IS (<>); + W : INTEGER; + PROCEDURE P (STR : STRING); + + PROCEDURE P (STR : STRING) IS + SUBTYPE NOENUM IS E RANGE + E'VAL (IDENT_INT(2)) .. E'VAL (IDENT_INT(1)); + BEGIN + IF E'WIDTH /= IDENT_INT(W) THEN + FAILED ( "INCORRECT E'WIDTH FOR " & STR ); + END IF; + IF NOENUM'WIDTH /= IDENT_INT(0) THEN + FAILED ( "INCORRECT NOENUM'WIDTH FOR " & STR ); + END IF; + END P; + + PROCEDURE PROC1 IS NEW P (ENUM, 5); + PROCEDURE PROC2 IS NEW P (SUBENUM, 3); + PROCEDURE PROC3 IS NEW P (NEWENUM, 5); + PROCEDURE PROC4 IS NEW P (NOENUM, 0); + + BEGIN + PROC1 ( "ENUM" ); + PROC2 ( "SUBENUM" ); + PROC3 ( "NEWENUM" ); + PROC4 ( "NOENUM" ); + END; + + RESULT; +END C35502B; diff --git a/gcc-4.9/gcc/testsuite/ada/acats/tests/c3/c35502c.ada b/gcc-4.9/gcc/testsuite/ada/acats/tests/c3/c35502c.ada new file mode 100644 index 000000000..a635e68fb --- /dev/null +++ b/gcc-4.9/gcc/testsuite/ada/acats/tests/c3/c35502c.ada @@ -0,0 +1,318 @@ +-- C35502C.ADA + +-- Grant of Unlimited Rights +-- +-- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687, +-- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained +-- unlimited rights in the software and documentation contained herein. +-- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making +-- this public release, the Government intends to confer upon all +-- recipients unlimited rights equal to those held by the Government. +-- These rights include rights to use, duplicate, release or disclose the +-- released technical data and computer software in whole or in part, in +-- any manner and for any purpose whatsoever, and to have or permit others +-- to do so. +-- +-- DISCLAIMER +-- +-- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR +-- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED +-- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF 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 ATTRIBUTES 'IMAGE' AND 'VALUE' YIELD THE CORRECT +-- RESULTS WHEN THE PREFIX IS AN ENUMERATION TYPE OTHER THAN A BOOLEAN +-- OR A CHARACTER TYPE. +-- SUBTESTS ARE: +-- PART (A). TESTS FOR IMAGE. +-- PART (B). TESTS FOR VALUE. + +-- RJW 5/07/86 + +WITH REPORT; USE REPORT; + +PROCEDURE C35502C IS + + TYPE ENUM IS (A, BC, ABC, A_B_C, abcd); + SUBTYPE SUBENUM IS ENUM RANGE A .. BC; + + TYPE NEWENUM IS NEW ENUM; + + FUNCTION IDENT (X : ENUM) RETURN ENUM IS + BEGIN + IF EQUAL (ENUM'POS (X), ENUM'POS(X)) THEN + RETURN X; + END IF; + RETURN ENUM'FIRST; + END IDENT; + +BEGIN + + TEST( "C35502C" , "CHECK THAT THE ATTRIBUTES 'IMAGE' AND " & + "'VALUE' YIELD THE CORRECT RESULTS " & + "WHEN THE PREFIX IS AN ENUMERATION TYPE " & + "OTHER THAN A BOOLEAN OR A CHARACTER TYPE" ); + +-- PART (A). + + BEGIN + + IF ENUM'IMAGE ( IDENT(ABC) ) /= "ABC" THEN + FAILED ( "INCORRECT ENUM'IMAGE FOR ABC" ); + END IF; + IF ENUM'IMAGE ( IDENT(ABC) )'FIRST /= 1 THEN + FAILED ( "INCORRECT LOWER BOUND FOR ABC IN ENUM" ); + END IF; + + IF ENUM'IMAGE ( IDENT(A_B_C) ) /= "A_B_C" THEN + FAILED ( "INCORRECT ENUM'IMAGE FOR A_B_C" ); + END IF; + IF ENUM'IMAGE ( IDENT(A_B_C) )'FIRST /= 1 THEN + FAILED ( "INCORRECT LOWER BOUND FOR A_B_C IN ENUM" ); + END IF; + + IF SUBENUM'IMAGE ( IDENT(A_B_C) ) /= "A_B_C" THEN + FAILED ( "INCORRECT SUBENUM'IMAGE FOR A_B_C" ); + END IF; + IF SUBENUM'IMAGE ( IDENT(ABC) )'FIRST /= 1 THEN + FAILED ( "INCORRECT LOWER BOUND FOR ABC " & + "IN SUBENUM" ); + END IF; + + IF NEWENUM'IMAGE ( ABC ) /= IDENT_STR("ABC") THEN + FAILED ( "INCORRECT NEWENUM'IMAGE FOR ABC" ); + END IF; + IF NEWENUM'IMAGE ( ABC )'FIRST /= IDENT_INT(1) THEN + FAILED ( "INCORRECT LOWER BOUND FOR ABC" & + "IN NEWENUM" ); + END IF; + + IF ENUM'IMAGE ( IDENT(abcd) ) /= "ABCD" THEN + FAILED ( "INCORRECT ENUM'IMAGE FOR abcd" ); + END IF; + IF ENUM'IMAGE ( IDENT(abcd) )'FIRST /= 1 THEN + FAILED ( "INCORRECT LOWER BOUND FOR abcd IN ENUM" ); + END IF; + + END; + +----------------------------------------------------------------------- + +-- PART (B). + + BEGIN + IF ENUM'VALUE (IDENT_STR("ABC")) /= ABC THEN + FAILED ( "INCORRECT VALUE FOR ""ABC""" ); + END IF; + EXCEPTION + WHEN OTHERS => + FAILED ( "EXCEPTION RAISED - VALUE FOR ""ABC""" ); + END; + + BEGIN + IF ENUM'VALUE (IDENT_STR("abc")) /= abc THEN + FAILED ( "INCORRECT VALUE FOR ""abc""" ); + END IF; + EXCEPTION + WHEN OTHERS => + FAILED ( "EXCEPTION RAISED - VALUE FOR ""abc""" ); + END; + + BEGIN + IF ENUM'VALUE ("ABC") /= ABC THEN + FAILED ( "INCORRECT VALUE FOR ABC" ); + END IF; + EXCEPTION + WHEN OTHERS => + FAILED ( "EXCEPTION RAISED - VALUE FOR ABC" ); + END; + + BEGIN + IF NEWENUM'VALUE (IDENT_STR("abcd")) /= abcd THEN + FAILED ( "INCORRECT VALUE FOR ""abcd""" ); + END IF; + EXCEPTION + WHEN OTHERS => + FAILED ( "EXCEPTION RAISED - VALUE FOR ""abcd""" ); + END; + + BEGIN + IF NEWENUM'VALUE (IDENT_STR("ABCD")) /= abcd THEN + FAILED ( "INCORRECT VALUE FOR ""ABCD""" ); + END IF; + EXCEPTION + WHEN OTHERS => + FAILED ( "EXCEPTION RAISED - VALUE FOR ""ABCD""" ); + END; + + BEGIN + IF NEWENUM'VALUE ("abcd") /= abcd THEN + FAILED ( "INCORRECT VALUE FOR abcd" ); + END IF; + EXCEPTION + WHEN OTHERS => + FAILED ( "EXCEPTION RAISED - VALUE FOR abcd" ); + END; + + BEGIN + IF SUBENUM'VALUE (IDENT_STR("A_B_C")) /= A_B_C THEN + FAILED ( "INCORRECT VALUE FOR ""A_B_C""" ); + END IF; + EXCEPTION + WHEN OTHERS => + FAILED ( "EXCEPTION RAISED - VALUE FOR ""A_B_C""" ); + END; + + BEGIN + IF ENUM'VALUE (IDENT_STR("ABC ")) /= ABC THEN + FAILED ( "INCORRECT VALUE WITH TRAILING BLANKS" ); + END IF; + EXCEPTION + WHEN OTHERS => + FAILED ( "EXCEPTION RAISED - VALUE WITH " & + "TRAILING BLANKS" ); + END; + + BEGIN + IF NEWENUM'VALUE (IDENT_STR(" A_B_C")) /= A_B_C THEN + FAILED ( "INCORRECT VALUE WITH LEADING BLANKS" ); + END IF; + EXCEPTION + WHEN OTHERS => + FAILED ( "EXCEPTION RAISED - VALUE WITH LEADING " & + "BLANKS" ); + END; + + BEGIN + IF ENUM'VALUE (IDENT_STR("A_BC")) /= ABC THEN + FAILED ( "NO EXCEPTION RAISED - ""A_BC"" - 1" ); + ELSE + FAILED ( "NO EXCEPTION RAISED - ""A_BC"" - 2" ); + END IF; + EXCEPTION + WHEN CONSTRAINT_ERROR => + NULL; + WHEN OTHERS => + FAILED ( "WRONG EXCEPTION RAISED - ""A_BC""" ); + END; + + BEGIN + IF ENUM'VALUE (IDENT_STR("A BC")) /= ABC THEN + FAILED ( "NO EXCEPTION RAISED - ""A BC"" - 1" ); + ELSE + FAILED ( "NO EXCEPTION RAISED - ""A BC"" - 2" ); + END IF; + EXCEPTION + WHEN CONSTRAINT_ERROR => + NULL; + WHEN OTHERS => + FAILED ( "WRONG EXCEPTION RAISED - ""A BC""" ); + END; + + BEGIN + IF ENUM'VALUE (IDENT_STR("A&BC")) /= ABC THEN + FAILED ( "NO EXCEPTION RAISED - ""A&BC"" - 1" ); + ELSE + FAILED ( "NO EXCEPTION RAISED - ""A&BC"" - 2" ); + END IF; + EXCEPTION + WHEN CONSTRAINT_ERROR => + NULL; + WHEN OTHERS => + FAILED ( "WRONG EXCEPTION RAISED - ""A&BC""" ); + END; + + BEGIN + IF ENUM'VALUE (IDENT_CHAR(ASCII.HT) & "BC") /= BC THEN + FAILED ( "NO EXCEPTION RAISED - LEADING 'HT' - 1" ); + ELSE + FAILED ( "NO EXCEPTION RAISED - LEADING 'HT' - 2" ); + END IF; + EXCEPTION + WHEN CONSTRAINT_ERROR => + NULL; + WHEN OTHERS => + FAILED ( "WRONG EXCEPTION RAISED - LEADING 'HT'" ); + END; + + BEGIN + IF NEWENUM'VALUE ("A" & (IDENT_CHAR(ASCII.HT))) /= A THEN + FAILED ( "NO EXCEPTION RAISED - TRAILING 'HT' - 1" ); + ELSE + FAILED ( "NO EXCEPTION RAISED - TRAILING 'HT' - 2" ); + END IF; + EXCEPTION + WHEN CONSTRAINT_ERROR => + NULL; + WHEN OTHERS => + FAILED ( "WRONG EXCEPTION RAISED - TRAILING 'HT'" ); + END; + + BEGIN + IF ENUM'VALUE (IDENT_STR("B__C")) /= BC THEN + FAILED ( "NO EXCEPTION RAISED - " & + "CONSECUTIVE UNDERSCORES - 1" ); + ELSE + FAILED ( "NO EXCEPTION RAISED - " & + "CONSECUTIVE UNDERSCORES - 2" ); + END IF; + EXCEPTION + WHEN CONSTRAINT_ERROR => + NULL; + WHEN OTHERS => + FAILED ( "WRONG EXCEPTION RAISED - " & + "CONSECUTIVE UNDERSCORES" ); + END; + + BEGIN + IF NEWENUM'VALUE (IDENT_STR("BC_")) /= BC THEN + FAILED ( "NO EXCEPTION RAISED - " & + "TRAILING UNDERSCORE - 1" ); + ELSE + FAILED ( "NO EXCEPTION RAISED - " & + "TRAILING UNDERSCORE - 2" ); + END IF; + EXCEPTION + WHEN CONSTRAINT_ERROR => + NULL; + WHEN OTHERS => + FAILED ( "WRONG EXCEPTION RAISED - " & + "TRAILING UNDERSCORE" ); + END; + + BEGIN + IF SUBENUM'VALUE (IDENT_STR("_BC")) /= BC THEN + FAILED ( "NO EXCEPTION RAISED - " & + "LEADING UNDERSCORE - 1" ); + ELSE + FAILED ( "NO EXCEPTION RAISED - " & + "LEADING UNDERSCORE - 2" ); + END IF; + EXCEPTION + WHEN CONSTRAINT_ERROR => + NULL; + WHEN OTHERS => + FAILED ( "WRONG EXCEPTION RAISED - " & + "LEADING UNDERSCORE" ); + END; + + BEGIN + IF SUBENUM'VALUE (IDENT_STR("0BC")) /= BC THEN + FAILED ( "NO EXCEPTION RAISED - " & + "FIRST CHARACTER IS A DIGIT - 1" ); + ELSE + FAILED ( "NO EXCEPTION RAISED - " & + "FIRST CHARACTER IS A DIGIT - 2" ); + END IF; + EXCEPTION + WHEN CONSTRAINT_ERROR => + NULL; + WHEN OTHERS => + FAILED ( "WRONG EXCEPTION RAISED - " & + "FIRST CHARACTER IS A DIGIT" ); + END; + + RESULT; +END C35502C; diff --git a/gcc-4.9/gcc/testsuite/ada/acats/tests/c3/c35502d.tst b/gcc-4.9/gcc/testsuite/ada/acats/tests/c3/c35502d.tst new file mode 100644 index 000000000..7da988197 --- /dev/null +++ b/gcc-4.9/gcc/testsuite/ada/acats/tests/c3/c35502d.tst @@ -0,0 +1,84 @@ +-- C35502D.TST + +-- Grant of Unlimited Rights +-- +-- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687, +-- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained +-- unlimited rights in the software and documentation contained herein. +-- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making +-- this public release, the Government intends to confer upon all +-- recipients unlimited rights equal to those held by the Government. +-- These rights include rights to use, duplicate, release or disclose the +-- released technical data and computer software in whole or in part, in +-- any manner and for any purpose whatsoever, and to have or permit others +-- to do so. +-- +-- DISCLAIMER +-- +-- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR +-- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED +-- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE +-- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE +-- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A +-- PARTICULAR PURPOSE OF SAID MATERIAL. +--* +-- CHECK THAT 'IMAGE' AND 'VALUE' YIELD THE CORRECT RESULT FOR THE +-- LONGEST POSSIBLE ENUMERATION LITERAL. + +-- RJW 2/21/86 + +WITH REPORT; USE REPORT; + +PROCEDURE C35502D IS + +BEGIN + TEST ("C35502D", "CHECK THAT 'IMAGE' AND 'VALUE' YIELD " & + "CORRECT RESULTS FOR THE LONGEST POSSIBLE " & + "ENUMERATION LITERAL"); + + -- BIG_ID1 IS A MAXIMUM LENGTH IDENTIFIER. BIG_STRING1 AND + -- BIG_STRING2 ARE TWO STRING LITERALS WHICH WHEN CONCATENATED + -- FORM THE IMAGE OF BIG_ID1; + + + DECLARE + TYPE ENUM IS ( +$BIG_ID1 + ); + + BEGIN + BEGIN + IF ENUM'VALUE ( +$BIG_STRING1 +& +$BIG_STRING2 +) /= +$BIG_ID1 + THEN + FAILED ( "INCORRECT RESULTS FOR 'VALUE'" ); + END IF; + EXCEPTION + WHEN OTHERS => + FAILED ( "EXCEPTION RAISED FOR 'VALUE'" ); + END; + BEGIN + IF ENUM'IMAGE( +$BIG_ID1 +) /= +( +$BIG_STRING1 +& +$BIG_STRING2 +) THEN + FAILED ( "INCORRECT RESULTS FOR 'IMAGE'" ); + END IF; + EXCEPTION + WHEN CONSTRAINT_ERROR => + FAILED ( "CONSTRAINT_ERROR RAISED FOR 'IMAGE'" ); + WHEN OTHERS => + FAILED ( "OTHER EXCEPTION RAISED FOR 'IMAGE'" ); + END; + END; + + RESULT; +END C35502D; diff --git a/gcc-4.9/gcc/testsuite/ada/acats/tests/c3/c35502e.ada b/gcc-4.9/gcc/testsuite/ada/acats/tests/c3/c35502e.ada new file mode 100644 index 000000000..16e3cf098 --- /dev/null +++ b/gcc-4.9/gcc/testsuite/ada/acats/tests/c3/c35502e.ada @@ -0,0 +1,155 @@ +-- C35502E.ADA + +-- Grant of Unlimited Rights +-- +-- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687, +-- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained +-- unlimited rights in the software and documentation contained herein. +-- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making +-- this public release, the Government intends to confer upon all +-- recipients unlimited rights equal to those held by the Government. +-- These rights include rights to use, duplicate, release or disclose the +-- released technical data and computer software in whole or in part, in +-- any manner and for any purpose whatsoever, and to have or permit others +-- to do so. +-- +-- DISCLAIMER +-- +-- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR +-- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED +-- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF 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 ATTRIBUTES 'IMAGE' AND 'VALUE' YIELD THE CORRECT +-- RESULTS WHEN THE PREFIX IS A FORMAL DISCRETE TYPE WHOSE ACTUAL +-- PARAMETER IS AN ENUMERATION TYPE OTHER THAN A BOOLEAN OR A +-- CHARACTER TYPE. +-- SUBTESTS ARE: +-- PART (A). TESTS FOR IMAGE. +-- PART (B). TESTS FOR VALUE. + +-- RJW 5/13/86 + +WITH REPORT; USE REPORT; + +PROCEDURE C35502E IS + + TYPE ENUM IS (A, BC, ABC, A_B_C, abcd); + SUBTYPE SUBENUM IS ENUM RANGE A .. BC; + + TYPE NEWENUM IS NEW ENUM; + +BEGIN + + TEST( "C35502E" , "CHECK THAT THE ATTRIBUTES 'IMAGE' AND " & + "'VALUE' YIELD THE CORRECT RESULTS WHEN THE " & + "PREFIX IS A FORMAL DISCRETE TYPE WHOSE " & + "ACTUAL PARAMETER IS AN ENUMERATION TYPE " & + "OTHER THAN A BOOLEAN OR A CHARACTER TYPE" ); + +-- PART (A). + DECLARE + GENERIC + TYPE E IS (<>); + STR1 : STRING; + PROCEDURE P ( E1 : E; STR2 : STRING ); + + PROCEDURE P ( E1 : E; STR2 : STRING ) IS + SUBTYPE SE IS E RANGE E'VAL(0) .. E'VAL(1); + BEGIN + IF SE'IMAGE ( E1 ) /= STR2 THEN + FAILED ( "INCORRECT SE'IMAGE FOR " & STR2 & " IN " + & STR1 ); + END IF; + IF SE'IMAGE ( E1 )'FIRST /= 1 THEN + FAILED ( "INCORRECT LOWER BOUND FOR " & STR2 + & " IN " & STR1 ); + END IF; + END P; + + PROCEDURE PE IS NEW P ( ENUM , "ENUM" ); + PROCEDURE PS IS NEW P ( SUBENUM, "SUBENUM" ); + PROCEDURE PN IS NEW P ( NEWENUM, "NEWENUM" ); + + BEGIN + PE ( ABC, "ABC" ); + PE ( A_B_C, "A_B_C" ); + PS ( BC, "BC" ); + PN ( ABC, "ABC" ); + PE ( abcd, "ABCD" ); + END; + +----------------------------------------------------------------------- + +-- PART (B). + + DECLARE + GENERIC + TYPE E IS (<>); + STR1 : STRING; + PROCEDURE P ( STR2 : STRING ; E1 : E ); + + PROCEDURE P ( STR2 : STRING ; E1 : E ) IS + SUBTYPE SE IS E RANGE E'VAL(0) .. E'VAL(1); + BEGIN + IF E'VALUE ( STR2 ) /= E1 THEN + FAILED ( "INCORRECT " & STR1 & "'VALUE FOR """ & + STR2 & """" ); + END IF; + EXCEPTION + WHEN OTHERS => + FAILED ( "EXCEPTION RAISED - " & STR1 & "'VALUE " & + "FOR """ & STR2 & """" ); + END P; + + PROCEDURE PE IS NEW P ( ENUM , "ENUM" ); + PROCEDURE PN IS NEW P ( NEWENUM, "NEWENUM" ); + + BEGIN + PN ("abcd", abcd); + PN ("A_B_C", A_B_C); + PE ("ABC ", ABC); + PE (" A_B_C", A_B_C); + END; + + + DECLARE + GENERIC + TYPE E IS (<>); + PROCEDURE P ( STR : STRING ); + + PROCEDURE P ( STR : STRING ) IS + SUBTYPE SE IS E RANGE E'VAL(0) .. E'VAL(1); + BEGIN + IF SE'VALUE (STR) = SE'VAL (0) THEN + FAILED ( "NO EXCEPTION RAISED - " & STR & " - 1" ); + ELSE + FAILED ( "NO EXCEPTION RAISED - " & STR & " - 2" ); + END IF; + EXCEPTION + WHEN CONSTRAINT_ERROR => + NULL; + WHEN OTHERS => + FAILED ( "WRONG EXCEPTION RAISED - " & STR ); + END P; + + PROCEDURE PE IS NEW P ( ENUM ); + PROCEDURE PS IS NEW P ( SUBENUM ); + PROCEDURE PN IS NEW P ( NEWENUM ); + + BEGIN + PS ("A BC"); + PN ("A&BC"); + PE (ASCII.HT & "BC"); + PE ("A" & ASCII.HT); + PS ("_BC"); + PN ("BC_"); + PE ("B__C"); + PE ("0BC"); + + END; + + RESULT; +END C35502E; diff --git a/gcc-4.9/gcc/testsuite/ada/acats/tests/c3/c35502f.tst b/gcc-4.9/gcc/testsuite/ada/acats/tests/c3/c35502f.tst new file mode 100644 index 000000000..30be23e47 --- /dev/null +++ b/gcc-4.9/gcc/testsuite/ada/acats/tests/c3/c35502f.tst @@ -0,0 +1,89 @@ +-- C35502F.TST + +-- Grant of Unlimited Rights +-- +-- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687, +-- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained +-- unlimited rights in the software and documentation contained herein. +-- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making +-- this public release, the Government intends to confer upon all +-- recipients unlimited rights equal to those held by the Government. +-- These rights include rights to use, duplicate, release or disclose the +-- released technical data and computer software in whole or in part, in +-- any manner and for any purpose whatsoever, and to have or permit others +-- to do so. +-- +-- DISCLAIMER +-- +-- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR +-- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED +-- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE +-- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE +-- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A +-- PARTICULAR PURPOSE OF SAID MATERIAL. +--* +-- CHECK THAT IMAGE AND VALUE ATTRIBUTES ARE CORRECT FOR A FORMAL +-- DISCRETE TYPE WHOSE ACTUAL PARAMETER IS AN ENUMERATED TYPE +-- WITH THE LONGEST POSSIBLE IDENTIFIER AS ONE CONSTANT. + +-- PWB 03/05/86 +-- DWC 07/22/87 -- ADDED THE CONSTANT STRING 'STR'. + +WITH REPORT; USE REPORT; + +PROCEDURE C35502F IS + + -- BIG_ID1 IS AN IDENTIFIER OF MAXIMUM LENGTH. + TYPE ENUM IS ( EVAL1, +$BIG_ID1 + ); + + -- BIG_STRING1 & BIG_STRING2 YIELDS BIG_ID. + STR1 : CONSTANT STRING := +$BIG_STRING1; + STR2 : CONSTANT STRING := +$BIG_STRING2; + STR : CONSTANT STRING := STR1 & STR2; + + GENERIC + TYPE FORMAL IS (<>); + PROCEDURE GEN_PROC; + + PROCEDURE GEN_PROC IS + BEGIN + VALUE_CHECK: + BEGIN + IF FORMAL'VALUE (STR) /= FORMAL'LAST THEN + FAILED ("VALUE OF LONG STRING NOT LONG IDENTIFIER"); + END IF; + EXCEPTION + WHEN OTHERS => + FAILED ("EXCEPTION RAISED IN CHECKING " & + "VALUE ATTRIBUTE"); + END VALUE_CHECK; + + IMAGE_CHECK: + BEGIN + IF FORMAL'IMAGE (FORMAL'LAST) /= STR + THEN + FAILED ("IMAGE OF LONG IDENTIFIER NOT LONG STRING"); + END IF; + EXCEPTION + WHEN OTHERS => + FAILED ("EXCEPTION RAISED IN CHECKING " & + "IMAGE ATTRIBUTE"); + END IMAGE_CHECK; + + END GEN_PROC; + + PROCEDURE TEST_PROC IS NEW GEN_PROC (ENUM); + +BEGIN -- C35502F + + TEST ("C35502F", "IMAGE AND VALUE ATTRIBUTES FOR A FORMAL " & + "DISCRETE TYPE WITH ONE ACTUAL VALUE HAVING " & + "LONGEST POSSIBLE IDENTIFIER"); + TEST_PROC; + RESULT; + +END C35502F; diff --git a/gcc-4.9/gcc/testsuite/ada/acats/tests/c3/c35502g.ada b/gcc-4.9/gcc/testsuite/ada/acats/tests/c3/c35502g.ada new file mode 100644 index 000000000..aff9fb399 --- /dev/null +++ b/gcc-4.9/gcc/testsuite/ada/acats/tests/c3/c35502g.ada @@ -0,0 +1,84 @@ +-- C35502G.ADA + +-- Grant of Unlimited Rights +-- +-- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687, +-- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained +-- unlimited rights in the software and documentation contained herein. +-- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making +-- this public release, the Government intends to confer upon all +-- recipients unlimited rights equal to those held by the Government. +-- These rights include rights to use, duplicate, release or disclose the +-- released technical data and computer software in whole or in part, in +-- any manner and for any purpose whatsoever, and to have or permit others +-- to do so. +-- +-- DISCLAIMER +-- +-- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR +-- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED +-- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF 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 'PRED' AND 'SUCC' YIELD THE CORRECT RESULTS WHEN +-- THE PREFIX IS AN ENUMERATION TYPE OTHER THAN A BOOLEAN OR A +-- CHARACTER TYPE. + +-- RJW 5/27/86 + +WITH REPORT; USE REPORT; + +PROCEDURE C35502G IS + + TYPE ENUM IS (A, BC, ABC, A_B_C, ABCD); + SUBTYPE SUBENUM IS ENUM RANGE A .. BC; + + TYPE NEWENUM IS NEW ENUM; + SUBTYPE SUBNEW IS NEWENUM RANGE A .. BC; + +BEGIN + TEST ("C35502G", "CHECK THAT 'PRED' AND 'SUCC' YIELD THE " & + "CORRECT RESULTS WHEN THE PREFIX IS AN " & + "ENUMERATION TYPE OTHER THAN A CHARACTER " & + "OR A BOOLEAN TYPE" ); + + BEGIN + FOR I IN ENUM'VAL (1) .. ENUM'VAL (4) LOOP + IF SUBENUM'PRED (I) /= + ENUM'VAL (ENUM'POS (I) - 1) THEN + FAILED ("INCORRECT SUBENUM'PRED(" & + ENUM'IMAGE (I) & ")" ); + END IF; + END LOOP; + + FOR I IN ENUM'VAL (0) .. ENUM'VAL (3) LOOP + IF SUBENUM'SUCC (I) /= + ENUM'VAL (ENUM'POS (I) + 1) THEN + FAILED ("INCORRECT SUBENUM'SUCC(" & + ENUM'IMAGE (I) & ")" ); + END IF; + END LOOP; + END; + + BEGIN + FOR I IN NEWENUM'VAL (1) .. NEWENUM'VAL (4) LOOP + IF SUBNEW'PRED (I) /= + NEWENUM'VAL (NEWENUM'POS (I) - 1) THEN + FAILED ("INCORRECT SUBNEW'PRED(" & + NEWENUM'IMAGE (I) & ")" ); + END IF; + END LOOP; + + FOR I IN NEWENUM'VAL (0) .. NEWENUM'VAL (3) LOOP + IF SUBNEW'SUCC (I) /= + NEWENUM'VAL (NEWENUM'POS (I) + 1) THEN + FAILED ("INCORRECT SUBNEW'SUCC(" & + NEWENUM'IMAGE (I) & ")" ); + END IF; + END LOOP; + END; + + RESULT; +END C35502G; diff --git a/gcc-4.9/gcc/testsuite/ada/acats/tests/c3/c35502h.ada b/gcc-4.9/gcc/testsuite/ada/acats/tests/c3/c35502h.ada new file mode 100644 index 000000000..640e2e9de --- /dev/null +++ b/gcc-4.9/gcc/testsuite/ada/acats/tests/c3/c35502h.ada @@ -0,0 +1,82 @@ +-- C35502H.ADA + +-- Grant of Unlimited Rights +-- +-- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687, +-- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained +-- unlimited rights in the software and documentation contained herein. +-- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making +-- this public release, the Government intends to confer upon all +-- recipients unlimited rights equal to those held by the Government. +-- These rights include rights to use, duplicate, release or disclose the +-- released technical data and computer software in whole or in part, in +-- any manner and for any purpose whatsoever, and to have or permit others +-- to do so. +-- +-- DISCLAIMER +-- +-- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR +-- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED +-- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF 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 'PRED' AND 'SUCC' YIELD THE CORRECT RESULTS WHEN +-- THE PREFIX IS A FORMAL DISCRETE TYPE WHOSE ACTUAL ARGUMENT IS +-- AN ENUMERATION TYPE OTHER THAN A BOOLEAN OR A CHARACTER TYPE. + +-- RJW 5/27/86 + +WITH REPORT; USE REPORT; + +PROCEDURE C35502H IS + + TYPE ENUM IS (A, BC, ABC, A_B_C, ABCD); + + TYPE NEWENUM IS NEW ENUM; + +BEGIN + TEST ("C35502H", "CHECK THAT 'PRED' AND 'SUCC' YIELD THE " & + "CORRECT RESULTS WHEN THE PREFIX IS A " & + "FORMAL DISCRETE TYPE WHOSE ACTUAL " & + "ARGUMENT IS AN ENUMERATION TYPE OTHER THAN " & + "A CHARACTER OR A BOOLEAN TYPE" ); + + DECLARE + GENERIC + TYPE E IS (<>); + STR : STRING; + PROCEDURE P; + + PROCEDURE P IS + SUBTYPE SE IS E RANGE E'VAL(0) .. E'VAL(1); + BEGIN + FOR I IN E'VAL (1) .. E'VAL (4) LOOP + IF SE'PRED (I) /= + E'VAL (E'POS (I) - 1) THEN + FAILED ("INCORRECT " & STR & "'PRED(" & + E'IMAGE (I) & ")" ); + END IF; + END LOOP; + + FOR I IN E'VAL (0) .. E'VAL (3) LOOP + IF SE'SUCC (I) /= + E'VAL (E'POS (I) + 1) THEN + FAILED ("INCORRECT " & STR & "'SUCC(" & + E'IMAGE (I) & ")" ); + END IF; + END LOOP; + + END P; + + PROCEDURE PE IS NEW P ( ENUM, "ENUM" ); + PROCEDURE PN IS NEW P ( NEWENUM, "NEWENUM" ); + + BEGIN + PE; + PN; + END; + + RESULT; +END C35502H; diff --git a/gcc-4.9/gcc/testsuite/ada/acats/tests/c3/c35502i.ada b/gcc-4.9/gcc/testsuite/ada/acats/tests/c3/c35502i.ada new file mode 100644 index 000000000..a9116d60b --- /dev/null +++ b/gcc-4.9/gcc/testsuite/ada/acats/tests/c3/c35502i.ada @@ -0,0 +1,91 @@ +-- C35502I.ADA + +-- Grant of Unlimited Rights +-- +-- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687, +-- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained +-- unlimited rights in the software and documentation contained herein. +-- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making +-- this public release, the Government intends to confer upon all +-- recipients unlimited rights equal to those held by the Government. +-- These rights include rights to use, duplicate, release or disclose the +-- released technical data and computer software in whole or in part, in +-- any manner and for any purpose whatsoever, and to have or permit others +-- to do so. +-- +-- DISCLAIMER +-- +-- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR +-- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED +-- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF 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 'PRED' AND 'SUCC' YIELD THE CORRECT RESULTS WHEN +-- THE PREFIX IS AN ENUMERATION TYPE, OTHER THAN A BOOLEAN OR A +-- CHARACTER TYPE, WITH A REPRESENTATION CLAUSE. + +-- HISTORY: +-- RJW 05/27/86 CREATED ORIGINAL TEST. +-- BCB 01/04/88 MODIFIED HEADER. +-- PWB 05/11/89 CHANGED EXTENSION FROM '.DEP' TO '.ADA'. + +WITH REPORT; USE REPORT; + +PROCEDURE C35502I IS + + TYPE ENUM IS (A, BC, ABC, A_B_C, ABCD); + FOR ENUM USE (A => 2, BC => 4, ABC => 6, + A_B_C => 8, ABCD => 10); + SUBTYPE SUBENUM IS ENUM RANGE A .. BC; + + TYPE NEWENUM IS NEW ENUM; + SUBTYPE SUBNEW IS NEWENUM RANGE A .. BC; + +BEGIN + TEST ("C35502I", "CHECK THAT 'PRED' AND 'SUCC' YIELD THE " & + "CORRECT RESULTS WHEN THE PREFIX IS AN " & + "ENUMERATION TYPE, OTHER THAN A CHARACTER " & + "OR A BOOLEAN TYPE, WITH A REPRESENTATION " & + "CLAUSE" ); + + BEGIN + FOR I IN ENUM'VAL (1) .. ENUM'VAL (4) LOOP + IF SUBENUM'PRED (I) /= + ENUM'VAL (ENUM'POS (I) - 1) THEN + FAILED ("INCORRECT SUBENUM'PRED(" & + ENUM'IMAGE (I) & ")" ); + END IF; + END LOOP; + + FOR I IN ENUM'VAL (0) .. ENUM'VAL (3) LOOP + IF SUBENUM'SUCC (I) /= + ENUM'VAL (ENUM'POS (I) + 1) THEN + FAILED ("INCORRECT SUBENUM'SUCC(" & + ENUM'IMAGE (I) & ")" ); + END IF; + END LOOP; + END; + + BEGIN + FOR I IN NEWENUM'VAL (1) .. NEWENUM'VAL (4) LOOP + IF SUBNEW'PRED (I) /= + NEWENUM'VAL (NEWENUM'POS (I) - 1) THEN + FAILED ("INCORRECT SUBNEW'PRED(" & + NEWENUM'IMAGE (I) & ")" ); + END IF; + END LOOP; + + FOR I IN NEWENUM'VAL (0) .. NEWENUM'VAL (3) LOOP + IF SUBNEW'SUCC (I) /= + NEWENUM'VAL (NEWENUM'POS (I) + 1) THEN + FAILED ("INCORRECT SUBNEW'SUCC(" & + NEWENUM'IMAGE (I) & ")" ); + END IF; + END LOOP; + END; + + RESULT; +END C35502I; diff --git a/gcc-4.9/gcc/testsuite/ada/acats/tests/c3/c35502j.ada b/gcc-4.9/gcc/testsuite/ada/acats/tests/c3/c35502j.ada new file mode 100644 index 000000000..37d17b259 --- /dev/null +++ b/gcc-4.9/gcc/testsuite/ada/acats/tests/c3/c35502j.ada @@ -0,0 +1,92 @@ +-- C35502J.ADA + +-- Grant of Unlimited Rights +-- +-- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687, +-- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained +-- unlimited rights in the software and documentation contained herein. +-- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making +-- this public release, the Government intends to confer upon all +-- recipients unlimited rights equal to those held by the Government. +-- These rights include rights to use, duplicate, release or disclose the +-- released technical data and computer software in whole or in part, in +-- any manner and for any purpose whatsoever, and to have or permit others +-- to do so. +-- +-- DISCLAIMER +-- +-- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR +-- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED +-- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF 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 'PRED' AND 'SUCC' YIELD THE CORRECT RESULTS WHEN +-- THE PREFIX IS A FORMAL DISCRETE TYPE WHOSE ACTUAL ARGUMENT IS +-- AN ENUMERATION TYPE, OTHER THAN A BOOLEAN OR A CHARACTER TYPE, +-- WITH AN ENUMERATION REPRESENTATION CLAUSE. + +-- HISTORY: +-- RJW 05/27/86 CREATED ORIGINAL TEST. +-- BCB 01/04/88 MODIFIED HEADER. +-- PWB 05/11/89 CHANGED EXTENSION FROM '.DEP' TO '.ADA'. + +WITH REPORT; USE REPORT; + +PROCEDURE C35502J IS + TYPE ENUM IS (A, BC, ABC, A_B_C, ABCD); + FOR ENUM USE (A => 2, BC => 4, ABC => 6, + A_B_C => 8, ABCD => 10); + + TYPE NEWENUM IS NEW ENUM; + +BEGIN + TEST ("C35502J", "CHECK THAT 'PRED' AND 'SUCC' YIELD THE " & + "CORRECT RESULTS WHEN THE PREFIX IS " & + "A FORMAL DISCRETE TYPE WHOSE ACTUAL " & + "ARGUMENT IS AN ENUMERATION TYPE, OTHER THAN " & + "A CHARACTER OR A BOOLEAN TYPE, WITH AN " & + "ENUMERATION REPRESENTATION CLAUSE" ); + + DECLARE + GENERIC + TYPE E IS (<>); + STR : STRING; + PROCEDURE P; + + PROCEDURE P IS + SUBTYPE SE IS E RANGE E'VAL(0) .. E'VAL(1); + + BEGIN + FOR I IN E'VAL (1) .. E'VAL (4) + LOOP + IF SE'PRED (I) /= + E'VAL (E'POS (I) - 1) THEN + FAILED ("INCORRECT " & STR & "'PRED(" & + E'IMAGE (I) & ")" ); + END IF; + END LOOP; + + FOR I IN E'VAL (0) .. E'VAL (3) + LOOP + IF SE'SUCC (I) /= + E'VAL (E'POS (I) + 1) THEN + FAILED ("INCORRECT " & STR & "'SUCC(" & + E'IMAGE (I) & ")" ); + END IF; + END LOOP; + + END P; + + PROCEDURE PE IS NEW P ( ENUM, "ENUM" ); + PROCEDURE PN IS NEW P ( NEWENUM, "NEWENUM" ); + + BEGIN + PE; + PN; + END; + + RESULT; +END C35502J; diff --git a/gcc-4.9/gcc/testsuite/ada/acats/tests/c3/c35502k.ada b/gcc-4.9/gcc/testsuite/ada/acats/tests/c3/c35502k.ada new file mode 100644 index 000000000..716521ba9 --- /dev/null +++ b/gcc-4.9/gcc/testsuite/ada/acats/tests/c3/c35502k.ada @@ -0,0 +1,174 @@ +-- C35502K.ADA + +-- Grant of Unlimited Rights +-- +-- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687, +-- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained +-- unlimited rights in the software and documentation contained herein. +-- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making +-- this public release, the Government intends to confer upon all +-- recipients unlimited rights equal to those held by the Government. +-- These rights include rights to use, duplicate, release or disclose the +-- released technical data and computer software in whole or in part, in +-- any manner and for any purpose whatsoever, and to have or permit others +-- to do so. +-- +-- DISCLAIMER +-- +-- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR +-- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED +-- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF 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 'POS' AND 'VAL' YIELD THE CORRECT RESULTS WHEN +-- THE PREFIX IS AN ENUMERATION TYPE OTHER THAN A BOOLEAN OR A +-- CHARACTER TYPE. + +-- RJW 5/27/86 +-- GMT 7/02/87 ADDED ENUM'VAL(3) CHECK NEAR END OF 2ND BLOCK STATEMENT. + + +WITH REPORT; USE REPORT; + +PROCEDURE C35502K IS + + TYPE ENUM IS (A, BC, ABC, A_B_C, ABCD); + SUBTYPE SUBENUM IS ENUM RANGE A .. BC; + + TYPE NEWENUM IS NEW ENUM; + SUBTYPE SUBNEW IS NEWENUM RANGE A .. BC; + +BEGIN + TEST ("C35502K", "CHECK THAT 'POS' AND 'VAL' YIELD THE " & + "CORRECT RESULTS WHEN THE PREFIX IS AN " & + "ENUMERATION TYPE OTHER THAN A CHARACTER " & + "OR A BOOLEAN TYPE" ); + + DECLARE + POSITION : INTEGER; + BEGIN + POSITION := 0; + + FOR E IN ENUM LOOP + IF SUBENUM'POS (E) /= POSITION THEN + FAILED ( "INCORRECT SUBENUM'POS (" & + ENUM'IMAGE (E) & ")" ); + END IF; + + IF SUBENUM'VAL (POSITION) /= E THEN + FAILED ( "INCORRECT SUBENUM'VAL (" & + INTEGER'IMAGE (POSITION) & + ")" ); + END IF; + + POSITION := POSITION + 1; + END LOOP; + + POSITION := 0; + FOR E IN NEWENUM LOOP + IF SUBNEW'POS (E) /= POSITION THEN + FAILED ( "INCORRECT SUBNEW'POS (" & + NEWENUM'IMAGE (E) & ")" ); + END IF; + + IF SUBNEW'VAL (POSITION) /= E THEN + FAILED ( "INCORRECT SUBNEW'VAL (" & + INTEGER'IMAGE (POSITION) & + ")" ); + END IF; + + POSITION := POSITION + 1; + END LOOP; + END; + + DECLARE + FUNCTION A_B_C RETURN ENUM IS + BEGIN + RETURN ENUM'VAL (IDENT_INT (0)); + END A_B_C; + + BEGIN + IF ENUM'VAL (0) /= A_B_C THEN + FAILED ( "WRONG ENUM'VAL (0) WHEN HIDDEN " & + "BY FUNCTION - 1" ); + END IF; + + IF ENUM'VAL (0) = C35502K.A_B_C THEN + FAILED ( "WRONG ENUM'VAL (0) WHEN HIDDEN " & + "BY FUNCTION - 2" ); + END IF; + + IF ENUM'VAL (3) /= C35502K.A_B_C THEN + FAILED ( "WRONG ENUM'VAL (3) WHEN HIDDEN " & + "BY FUNCTION - 3" ); + END IF; + END; + + BEGIN + IF ENUM'VAL (IDENT_INT (-1)) = A THEN + FAILED ( "NO EXCEPTION RAISED " & + "FOR ENUM'VAL (IDENT_INT (-1)) - 1" ); + ELSE + FAILED ( "NO EXCEPTION RAISED " & + "FOR ENUM'VAL (IDENT_INT (-1)) - 2" ); + END IF; + EXCEPTION + WHEN CONSTRAINT_ERROR => + NULL; + WHEN OTHERS => + FAILED ( "WRONG EXCEPTION RAISED " & + "FOR ENUM'VAL (IDENT_INT (-1))" ); + END; + + BEGIN + IF NEWENUM'VAL (IDENT_INT (-1)) = A THEN + FAILED ( "NO EXCEPTION RAISED FOR " & + "NEWENUM'VAL (IDENT_INT (-1)) - 1" ); + ELSE + FAILED ( "NO EXCEPTION RAISED FOR " & + "NEWENUM'VAL (IDENT_INT (-1)) - 2" ); + END IF; + EXCEPTION + WHEN CONSTRAINT_ERROR => + NULL; + WHEN OTHERS => + FAILED ( "WRONG EXCEPTION RAISED FOR " & + "NEWENUM'VAL (IDENT_INT (-1))" ); + END; + + BEGIN + IF ENUM'VAL (IDENT_INT (5)) = A THEN + FAILED ( "NO EXCEPTION RAISED " & + "FOR ENUM'VAL (IDENT_INT (5)) - 1" ); + ELSE + FAILED ( "NO EXCEPTION RAISED " & + "FOR ENUM'VAL (IDENT_INT (5)) - 2" ); + END IF; + EXCEPTION + WHEN CONSTRAINT_ERROR => + NULL; + WHEN OTHERS => + FAILED ( "WRONG EXCEPTION RAISED " & + "FOR ENUM'VAL (IDENT_INT (5))" ); + END; + + BEGIN + IF NEWENUM'VAL (IDENT_INT (5)) = A THEN + FAILED ( "NO EXCEPTION RAISED FOR " & + "NEWENUM'VAL (IDENT_INT (5)) - 1" ); + ELSE + FAILED ( "NO EXCEPTION RAISED FOR " & + "NEWENUM'VAL (IDENT_INT (5)) - 2" ); + END IF; + EXCEPTION + WHEN CONSTRAINT_ERROR => + NULL; + WHEN OTHERS => + FAILED ( "WRONG EXCEPTION RAISED FOR " & + "NEWENUM'VAL (IDENT_INT (5))" ); + END; + + RESULT; +END C35502K; diff --git a/gcc-4.9/gcc/testsuite/ada/acats/tests/c3/c35502l.ada b/gcc-4.9/gcc/testsuite/ada/acats/tests/c3/c35502l.ada new file mode 100644 index 000000000..768c1435a --- /dev/null +++ b/gcc-4.9/gcc/testsuite/ada/acats/tests/c3/c35502l.ada @@ -0,0 +1,152 @@ +-- C35502L.ADA + +-- Grant of Unlimited Rights +-- +-- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687, +-- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained +-- unlimited rights in the software and documentation contained herein. +-- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making +-- this public release, the Government intends to confer upon all +-- recipients unlimited rights equal to those held by the Government. +-- These rights include rights to use, duplicate, release or disclose the +-- released technical data and computer software in whole or in part, in +-- any manner and for any purpose whatsoever, and to have or permit others +-- to do so. +-- +-- DISCLAIMER +-- +-- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR +-- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED +-- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF 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 'POS' AND 'VAL' YIELD THE CORRECT RESULTS WHEN +-- THE PREFIX IS A FORMAL DISCRETE TYPE WHOSE ACTUAL ARGUMENT IS +-- AN ENUMERATION TYPE OTHER THAN A BOOLEAN OR A CHARACTER TYPE. + +-- RJW 5/27/86 + +WITH REPORT; USE REPORT; + +PROCEDURE C35502L IS + + TYPE ENUM IS (A, BC, ABC, A_B_C, ABCD); + SUBTYPE SUBENUM IS ENUM RANGE A .. BC; + + TYPE NEWENUM IS NEW ENUM; + SUBTYPE SUBNEW IS NEWENUM RANGE A .. BC; + +BEGIN + TEST ("C35502L", "CHECK THAT 'POS' AND 'VAL' YIELD THE " & + "CORRECT RESULTS WHEN THE PREFIX IS A " & + "FORMAL DISCRETE TYPE WHOSE ACTUAL ARGUMENT " & + "IS AN ENUMERATION TYPE OTHER THAN A " & + "CHARACTER OR A BOOLEAN TYPE" ); + + DECLARE + + GENERIC + TYPE E IS (<>); + STR : STRING; + PROCEDURE P; + + PROCEDURE P IS + SUBTYPE SE IS E RANGE E'VAL(0) .. E'VAL(1); + POSITION : INTEGER; + BEGIN + + POSITION := 0; + + FOR E1 IN E + LOOP + IF SE'POS (E1) /= POSITION THEN + FAILED ( "INCORRECT SE'POS (" & + E'IMAGE (E1) & ")" ); + END IF; + + IF SE'VAL (POSITION) /= E1 THEN + FAILED ( "INCORRECT " & STR & "'VAL (" & + INTEGER'IMAGE (POSITION) & + ")" ); + END IF; + + POSITION := POSITION + 1; + END LOOP; + + BEGIN + IF E'VAL (-1) = E'VAL (1) THEN + FAILED ( "NO EXCEPTION RAISED FOR " & + STR & "'VAL (-1) - 1" ); + ELSE + FAILED ( "NO EXCEPTION RAISED FOR " & + STR & "'VAL (-1) - 2" ); + END IF; + EXCEPTION + WHEN CONSTRAINT_ERROR => + NULL; + WHEN OTHERS => + FAILED ( "WRONG EXCEPTION RAISED FOR " & + STR & "'VAL (-1)" ); + END; + + BEGIN + IF E'VAL (5) = E'VAL (4) THEN + FAILED ( "NO EXCEPTION RAISED FOR " & + STR & "'VAL (5) - 1" ); + ELSE + FAILED ( "NO EXCEPTION RAISED FOR " & + STR & "'VAL (5) - 2" ); + END IF; + EXCEPTION + WHEN CONSTRAINT_ERROR => + NULL; + WHEN OTHERS => + FAILED ( "WRONG EXCEPTION RAISED FOR " & + STR & "'VAL (5)" ); + END; + END P; + + PROCEDURE PE IS NEW P ( ENUM, "ENUM" ); + PROCEDURE PN IS NEW P ( NEWENUM, "NEWENUM" ); + BEGIN + PE; + PN; + END; + + DECLARE + GENERIC + TYPE E IS (<>); + FUNCTION F (E1 : E) RETURN BOOLEAN; + + FUNCTION F (E1 : E) RETURN BOOLEAN IS + BEGIN + RETURN E'VAL (0) = E1; + END F; + + FUNCTION FE IS NEW F (ENUM); + + BEGIN + + DECLARE + FUNCTION A_B_C RETURN ENUM IS + BEGIN + RETURN ENUM'VAL (IDENT_INT (0)); + END A_B_C; + BEGIN + IF FE (A_B_C) THEN + NULL; + ELSE + FAILED ( "INCORRECT VAL FOR A_B_C WHEN HIDDEN " & + "BY A FUNCTION" ); + END IF; + + IF FE (C35502L.A_B_C) THEN + FAILED ( "INCORRECT VAL FOR C35502L.A_B_C" ); + END IF; + END; + END; + + RESULT; +END C35502L; diff --git a/gcc-4.9/gcc/testsuite/ada/acats/tests/c3/c35502m.ada b/gcc-4.9/gcc/testsuite/ada/acats/tests/c3/c35502m.ada new file mode 100644 index 000000000..754ecc52c --- /dev/null +++ b/gcc-4.9/gcc/testsuite/ada/acats/tests/c3/c35502m.ada @@ -0,0 +1,177 @@ +-- C35502M.ADA + +-- Grant of Unlimited Rights +-- +-- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687, +-- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained +-- unlimited rights in the software and documentation contained herein. +-- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making +-- this public release, the Government intends to confer upon all +-- recipients unlimited rights equal to those held by the Government. +-- These rights include rights to use, duplicate, release or disclose the +-- released technical data and computer software in whole or in part, in +-- any manner and for any purpose whatsoever, and to have or permit others +-- to do so. +-- +-- DISCLAIMER +-- +-- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR +-- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED +-- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF 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 'POS' AND 'VAL' YIELD THE CORRECT RESULTS WHEN +-- THE PREFIX IS AN ENUMERATION TYPE, OTHER THAN A BOOLEAN OR A +-- CHARACTER TYPE, WITH AN ENUMERATION REPRESENTATION CLAUSE. + +-- HISTORY: +-- RJW 05/27/86 CREATED ORIGINAL TEST. +-- BCB 01/04/88 MODIFIED HEADER. +-- PWB 05/11/89 CHANGED EXTENSION FROM '.DEP' TO '.ADA'. + +WITH REPORT; USE REPORT; + +PROCEDURE C35502M IS + + TYPE ENUM IS (A, BC, ABC, A_B_C, ABCD); + FOR ENUM USE (A => 2, BC => 4, ABC => 6, + A_B_C => 8, ABCD => 10); + + SUBTYPE SUBENUM IS ENUM RANGE A .. BC; + + TYPE NEWENUM IS NEW ENUM; + SUBTYPE SUBNEW IS NEWENUM RANGE A .. BC; + +BEGIN + TEST ("C35502M", "CHECK THAT 'POS' AND 'VAL' YIELD THE " & + "CORRECT RESULTS WHEN THE PREFIX IS AN " & + "ENUMERATION TYPE, OTHER THAN A CHARACTER " & + "OR A BOOLEAN TYPE, WITH AN ENUMERATION " & + "REPRESENTATION CLAUSE" ); + + DECLARE + POSITION : INTEGER; + BEGIN + POSITION := 0; + + FOR E IN ENUM + LOOP + IF SUBENUM'POS (E) /= POSITION THEN + FAILED ( "INCORRECT SUBENUM'POS (" & + ENUM'IMAGE (E) & ")" ); + END IF; + + IF SUBENUM'VAL (POSITION) /= E THEN + FAILED ( "INCORRECT SUBENUM'VAL (" & + INTEGER'IMAGE (POSITION) & + ")" ); + END IF; + + POSITION := POSITION + 1; + END LOOP; + + POSITION := 0; + FOR E IN NEWENUM + LOOP + IF SUBNEW'POS (E) /= POSITION THEN + FAILED ( "INCORRECT SUBNEW'POS (" & + NEWENUM'IMAGE (E) & ")" ); + END IF; + + IF SUBNEW'VAL (POSITION) /= E THEN + FAILED ( "INCORRECT SUBNEW'VAL (" & + INTEGER'IMAGE (POSITION) & + ")" ); + END IF; + + POSITION := POSITION + 1; + END LOOP; + END; + + DECLARE + FUNCTION A_B_C RETURN ENUM IS + BEGIN + RETURN A; + END A_B_C; + + BEGIN + IF ENUM'VAL (0) /= A_B_C THEN + FAILED ( "WRONG ENUM'VAL (0) WHEN HIDDEN " & + "BY FUNCTION - 1" ); + END IF; + + IF ENUM'VAL (0) = C35502M.A_B_C THEN + FAILED ( "WRONG ENUM'VAL (0) WHEN HIDDEN " & + "BY FUNCTION - 2" ); + END IF; + END; + + BEGIN + IF ENUM'VAL (IDENT_INT (-1)) = ENUM'FIRST THEN + FAILED ( "NO EXCEPTION RAISED FOR " & + "ENUM'VAL (IDENT_INT (-1)) - 1" ); + ELSE + FAILED ( "NO EXCEPTION RAISED FOR " & + "ENUM'VAL (IDENT_INT (-1)) - 2" ); + END IF; + EXCEPTION + WHEN CONSTRAINT_ERROR => + NULL; + WHEN OTHERS => + FAILED ( "WRONG EXCEPTION RAISED FOR " & + "ENUM'VAL (IDENT_INT (-1))" ); + END; + + BEGIN + IF NEWENUM'VAL (IDENT_INT (-1)) = NEWENUM'LAST THEN + FAILED ( "NO EXCEPTION RAISED FOR " & + "NEWENUM'VAL (IDENT_INT (-1)) - 1" ); + ELSE + FAILED ( "NO EXCEPTION RAISED FOR " & + "NEWENUM'VAL (IDENT_INT (-1)) - 2" ); + END IF; + EXCEPTION + WHEN CONSTRAINT_ERROR => + NULL; + WHEN OTHERS => + FAILED ( "WRONG EXCEPTION RAISED FOR " & + "NEWENUM'VAL (IDENT_INT (-1))" ); + END; + + BEGIN + IF ENUM'VAL (IDENT_INT (5)) = ENUM'LAST THEN + FAILED ( "NO EXCEPTION RAISED FOR " & + "ENUM'VAL (IDENT_INT (5)) - 1" ); + ELSE + FAILED ( "NO EXCEPTION RAISED FOR " & + "ENUM'VAL (IDENT_INT (5)) - 2" ); + END IF; + EXCEPTION + WHEN CONSTRAINT_ERROR => + NULL; + WHEN OTHERS => + FAILED ( "WRONG EXCEPTION RAISED FOR " & + "ENUM'VAL (IDENT_INT (5))" ); + END; + + BEGIN + IF NEWENUM'VAL (IDENT_INT (5)) = NEWENUM'LAST THEN + FAILED ( "NO EXCEPTION RAISED FOR " & + "NEWENUM'VAL (IDENT_INT (5)) - 1" ); + ELSE + FAILED ( "NO EXCEPTION RAISED FOR " & + "NEWENUM'VAL (IDENT_INT (5)) - 2" ); + END IF; + EXCEPTION + WHEN CONSTRAINT_ERROR => + NULL; + WHEN OTHERS => + FAILED ( "WRONG EXCEPTION RAISED FOR " & + "NEWENUM'VAL (IDENT_INT (5))" ); + END; + + RESULT; +END C35502M; diff --git a/gcc-4.9/gcc/testsuite/ada/acats/tests/c3/c35502n.ada b/gcc-4.9/gcc/testsuite/ada/acats/tests/c3/c35502n.ada new file mode 100644 index 000000000..780120dbb --- /dev/null +++ b/gcc-4.9/gcc/testsuite/ada/acats/tests/c3/c35502n.ada @@ -0,0 +1,158 @@ +-- C35502N.ADA + +-- Grant of Unlimited Rights +-- +-- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687, +-- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained +-- unlimited rights in the software and documentation contained herein. +-- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making +-- this public release, the Government intends to confer upon all +-- recipients unlimited rights equal to those held by the Government. +-- These rights include rights to use, duplicate, release or disclose the +-- released technical data and computer software in whole or in part, in +-- any manner and for any purpose whatsoever, and to have or permit others +-- to do so. +-- +-- DISCLAIMER +-- +-- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR +-- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED +-- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF 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 'POS' AND 'VAL' YIELD THE CORRECT RESULTS WHEN +-- THE PREFIX IS A FORMAL DISCRETE TYPE WHOSE ACTUAL ARGUMENT IS +-- AN ENUMERATION TYPE, OTHER THAN A BOOLEAN OR A CHARACTER TYPE, +-- WITH AN ENUMERATION REPRESENTATION CLAUSE. + +-- HISTORY: +-- RJW 05/27/86 +-- DWC 07/22/87 ADDED THE PARAMETER 'N' TO FUNCTION F. +-- PWB 05/11/89 CHANGED EXTENSION FROM '.DEP' TO '.ADA'. + +WITH REPORT; USE REPORT; + +PROCEDURE C35502N IS + + TYPE ENUM IS (A, BC, ABC, A_B_C, ABCD); + FOR ENUM USE (A => 1, BC => 4, ABC => 5, A_B_C => 6, + ABCD => 8); + + SUBTYPE SUBENUM IS ENUM RANGE A .. BC; + + TYPE NEWENUM IS NEW ENUM; + SUBTYPE SUBNEW IS NEWENUM RANGE A .. BC; + +BEGIN + TEST ("C35502N", "CHECK THAT 'POS' AND 'VAL' YIELD THE " & + "CORRECT RESULTS WHEN THE PREFIX IS A " & + "FORMAL DISCRETE TYPE WHOSE ACTUAL ARGUMENT " & + "IS AN ENUMERATION TYPE, OTHER THAN A " & + "CHARACTER OR A BOOLEAN TYPE, WITH AN " & + "ENUMERATION REPRESENTATION CLAUSE" ); + + DECLARE + + GENERIC + TYPE E IS (<>); + STR : STRING; + PROCEDURE P; + + PROCEDURE P IS + SUBTYPE SE IS E RANGE E'VAL(0) .. E'VAL(1); + POSITION : INTEGER; + BEGIN + + POSITION := 0; + + FOR E1 IN E LOOP + IF SE'POS (E1) /= POSITION THEN + FAILED ( "INCORRECT " & STR & "'POS (" & + E'IMAGE (E1) & ")" ); + END IF; + + IF SE'VAL (POSITION) /= E1 THEN + FAILED ( "INCORRECT " & STR & "'VAL (" & + INTEGER'IMAGE (POSITION) & + ")" ); + END IF; + + POSITION := POSITION + 1; + END LOOP; + + BEGIN + IF E'VAL (-1) = E'VAL (1) THEN + FAILED ( "NO EXCEPTION RAISED FOR " & + STR & "'VAL (-1) - 1" ); + ELSE + FAILED ( "NO EXCEPTION RAISED FOR " & + STR & "'VAL (-1) - 2" ); + END IF; + EXCEPTION + WHEN CONSTRAINT_ERROR => + NULL; + WHEN OTHERS => + FAILED ( "WRONG EXCEPTION RAISED FOR " & + STR & "'VAL (-1)" ); + END; + + BEGIN + IF E'VAL (5) = E'VAL (4) THEN + FAILED ( "NO EXCEPTION RAISED FOR " & + STR & "'VAL (5) - 1" ); + ELSE + FAILED ( "NO EXCEPTION RAISED FOR " & + STR & "'VAL (5) - 2" ); + END IF; + EXCEPTION + WHEN CONSTRAINT_ERROR => + NULL; + WHEN OTHERS => + FAILED ( "WRONG EXCEPTION RAISED FOR " & + STR & "'VAL (5)" ); + END; + END P; + + PROCEDURE PE IS NEW P ( ENUM, "ENUM" ); + PROCEDURE PN IS NEW P ( NEWENUM, "NEWENUM" ); + BEGIN + PE; + PN; + END; + + DECLARE + FUNCTION A_B_C RETURN ENUM IS + BEGIN + RETURN ENUM'VAL (IDENT_INT (0)); + END A_B_C; + + GENERIC + TYPE E IS (<>); + FUNCTION F (N : INTEGER; + E1 : E) RETURN BOOLEAN; + + FUNCTION F (N : INTEGER; + E1 : E) RETURN BOOLEAN IS + BEGIN + RETURN E'VAL (N) = E1; + END F; + + FUNCTION FE IS NEW F (ENUM); + + BEGIN + + IF NOT FE (0, A_B_C) THEN + FAILED ( "INCORRECT VAL FOR A_B_C WHEN HIDDEN " & + "BY A FUNCTION" ); + END IF; + + IF NOT FE (3, C35502N.A_B_C) THEN + FAILED ( "INCORRECT VAL FOR C35502N.A_B_C" ); + END IF; + END; + + RESULT; +END C35502N; diff --git a/gcc-4.9/gcc/testsuite/ada/acats/tests/c3/c35502o.ada b/gcc-4.9/gcc/testsuite/ada/acats/tests/c3/c35502o.ada new file mode 100644 index 000000000..561e1e9aa --- /dev/null +++ b/gcc-4.9/gcc/testsuite/ada/acats/tests/c3/c35502o.ada @@ -0,0 +1,52 @@ +-- C35502O.ADA + +-- Grant of Unlimited Rights +-- +-- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687, +-- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained +-- unlimited rights in the software and documentation contained herein. +-- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making +-- this public release, the Government intends to confer upon all +-- recipients unlimited rights equal to those held by the Government. +-- These rights include rights to use, duplicate, release or disclose the +-- released technical data and computer software in whole or in part, in +-- any manner and for any purpose whatsoever, and to have or permit others +-- to do so. +-- +-- DISCLAIMER +-- +-- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR +-- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED +-- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF 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 'FIRST AND 'LAST GIVE CORRECT RESULTS FOR TYPES +-- AND SUBTYPES. + +-- DAT 3/17/81 +-- R. WILLIAMS 11/11/86 RENAMED FROM C35104A.ADA. + +WITH REPORT; USE REPORT; +PROCEDURE C35502O IS + + TYPE E IS (E1, E2, E3, E4, E5); + + SUBTYPE S IS E RANGE E2 .. E4; + +BEGIN + TEST ("C35502O", "CHECK THAT 'FIRST AND 'LAST WORK FOR" + & " ENUMERATION TYPES AND SUBTYPES"); + + IF E'FIRST /= E1 OR E'LAST /= E5 + OR E'BASE'FIRST /= E1 OR E'BASE'LAST /= E5 + OR S'BASE'FIRST /= E1 OR S'BASE'LAST /= E5 + OR S'FIRST /= E2 OR S'LAST /= E4 + OR BOOLEAN'FIRST /= FALSE OR BOOLEAN'LAST /= TRUE + THEN + FAILED ("'FIRST OR 'LAST GIVES WRONG RESULTS"); + END IF; + + RESULT; +END C35502O; diff --git a/gcc-4.9/gcc/testsuite/ada/acats/tests/c3/c35502p.ada b/gcc-4.9/gcc/testsuite/ada/acats/tests/c3/c35502p.ada new file mode 100644 index 000000000..1dfef9ab0 --- /dev/null +++ b/gcc-4.9/gcc/testsuite/ada/acats/tests/c3/c35502p.ada @@ -0,0 +1,122 @@ +-- C35502P.ADA + +-- Grant of Unlimited Rights +-- +-- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687, +-- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained +-- unlimited rights in the software and documentation contained herein. +-- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making +-- this public release, the Government intends to confer upon all +-- recipients unlimited rights equal to those held by the Government. +-- These rights include rights to use, duplicate, release or disclose the +-- released technical data and computer software in whole or in part, in +-- any manner and for any purpose whatsoever, and to have or permit others +-- to do so. +-- +-- DISCLAIMER +-- +-- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR +-- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED +-- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE +-- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE +-- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A +-- PARTICULAR PURPOSE OF SAID MATERIAL. +--* +-- OBJECTIVE: +-- FOR AN ENUMERATION TYPE OTHER THAN BOOLEAN OR CHARACTER TYPE, +-- CHECK THAT THE RESULTS AND TYPE PRODUCED BY THE ATTRIBUTES +-- ARE CORRECT. + +-- CHECK THAT 'FIRST AND 'LAST YIELD CORRECT RESULTS WHEN THE +-- PREFIX DENOTES A NULL SUBTYPE. + +-- HISTORY: +-- RJW 05/05/86 CREATED ORIGINAL TEST. +-- CJJ 06/09/87 CHANGED "=" COMPARISONS IN GENERIC +-- PROCEDURE Q TO "/=". + + +WITH REPORT; USE REPORT; + +PROCEDURE C35502P IS + +BEGIN + + TEST( "C35502P" , "CHECK THAT THE ATTRIBUTES 'FIRST' AND " & + "'LAST' YIELD THE CORRECT RESULTS WHEN THE " & + "PREFIX IS A GENERIC FORMAL DISCRETE TYPE " & + "WHOSE ACTUAL PARAMETER IS AN ENUMERATION " & + "TYPE OTHER THAN A CHARACTER OR A BOOLEAN " & + "TYPE" ); + + DECLARE + -- FOR THESE DECLARATIONS, 'FIRST AND 'LAST REFER TO THE + -- SUBTYPE VALUES, BUT 'VAL AND 'POS ARE INHERITED FROM THE + -- BASE TYPE. + + TYPE ENUM IS (A, BC, ABC, A_B_C, ABCD); + SUBTYPE SUBENUM IS ENUM RANGE A .. ABC; + + TYPE NEWENUM IS NEW ENUM RANGE BC .. A_B_C; + TYPE NONEWENUM IS NEW ENUM RANGE ABCD .. A; + GENERIC + TYPE E IS (<>); + F, L : E; + PROCEDURE P (STR : STRING); + + PROCEDURE P (STR : STRING) IS + SUBTYPE NOENUM IS E RANGE + E'VAL (IDENT_INT(2)) .. E'VAL (IDENT_INT(1)); + BEGIN + IF E'FIRST /= F THEN + FAILED ( "INCORRECT E'FIRST FOR " & STR ); + END IF; + IF NOENUM'FIRST /= E'VAL (2) THEN + FAILED ( "INCORRECT NOENUM'FIRST FOR " & STR ); + END IF; + + IF E'LAST /= L THEN + FAILED ( "INCORRECT E'LAST FOR " & STR ); + END IF; + IF NOENUM'LAST /= E'VAL (1) THEN + FAILED ( "INCORRECT NOENUM'LAST FOR " & STR ); + END IF; + END P; + + GENERIC + TYPE E IS (<>); + PROCEDURE Q; + + PROCEDURE Q IS + SUBTYPE NOENUM IS E RANGE + E'VAL (IDENT_INT(2)) .. E'VAL (IDENT_INT(1)); + BEGIN + IF E'FIRST /= E'VAL (IDENT_INT(4)) THEN + FAILED ( "INCORRECT E'FIRST FOR NONEWENUM" ); + END IF; + IF NOENUM'FIRST /= E'VAL (2) THEN + FAILED ( "INCORRECT NOENUM'FIRST FOR NONEWENUM"); + END IF; + + IF E'LAST /= E'VAL (IDENT_INT(0)) THEN + FAILED ( "INCORRECT E'LAST FOR NONEWENUM"); + END IF; + IF NOENUM'LAST /= E'VAL (1) THEN + FAILED ( "INCORRECT NOENUM'LAST FOR NONEWENUM"); + END IF; + END Q; + + PROCEDURE PROC1 IS NEW P (ENUM, A, ABCD); + PROCEDURE PROC2 IS NEW P (SUBENUM, A, ABC); + PROCEDURE PROC3 IS NEW P (NEWENUM, BC, A_B_C); + PROCEDURE PROC4 IS NEW Q (NONEWENUM); + + BEGIN + PROC1 ( "ENUM" ); + PROC2 ( "SUBENUM" ); + PROC3 ( "NEWENUM" ); + PROC4; + END; + + RESULT; +END C35502P; diff --git a/gcc-4.9/gcc/testsuite/ada/acats/tests/c3/c35503a.ada b/gcc-4.9/gcc/testsuite/ada/acats/tests/c3/c35503a.ada new file mode 100644 index 000000000..b9daf25f9 --- /dev/null +++ b/gcc-4.9/gcc/testsuite/ada/acats/tests/c3/c35503a.ada @@ -0,0 +1,80 @@ +-- C35503A.ADA + +-- Grant of Unlimited Rights +-- +-- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687, +-- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained +-- unlimited rights in the software and documentation contained herein. +-- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making +-- this public release, the Government intends to confer upon all +-- recipients unlimited rights equal to those held by the Government. +-- These rights include rights to use, duplicate, release or disclose the +-- released technical data and computer software in whole or in part, in +-- any manner and for any purpose whatsoever, and to have or permit others +-- to do so. +-- +-- DISCLAIMER +-- +-- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR +-- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED +-- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF 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 'WIDTH' YIELDS THE CORRECT RESULT WHEN THE PREFIX IS AN +-- INTEGER TYPE. + +-- RJW 3/12/86 + +WITH REPORT; USE REPORT; + +PROCEDURE C35503A IS + +BEGIN + TEST ("C35503A", "CHECK THAT 'WIDTH' YIELDS THE CORRECT " & + "RESULT WHEN THE PREFIX IS AN INTEGER TYPE" ); + + DECLARE + SUBTYPE SINTEGER IS INTEGER; + + TYPE INT IS RANGE -1000 .. 1000; + TYPE INT2 IS NEW INT RANGE 1E2 .. 1E2; + + SUBTYPE SINT1 IS INT RANGE 00000 .. 100; + SUBTYPE SINT2 IS INT RANGE 16#E#E1 .. 2#1111_1111#; + SUBTYPE SINT3 IS INT RANGE -100 .. 9; + SUBTYPE NOINT IS INT RANGE 1 .. -1; + + BEGIN + IF IDENT_INT(SINTEGER'WIDTH) /= INTEGER'WIDTH THEN + FAILED ( "WRONG WIDTH FOR 'SINTEGER'" ); + END IF; + + IF IDENT_INT(INT'WIDTH) /= 5 THEN + FAILED ( "WRONG WIDTH FOR 'INT'" ); + END IF; + + IF IDENT_INT(INT2'WIDTH) /= 4 THEN + FAILED ( "WRONG WIDTH FOR 'INT2'"); + END IF; + + IF IDENT_INT(SINT1'WIDTH) /= 4 THEN + FAILED ( "WRONG WIDTH FOR 'SINT1'" ); + END IF; + + IF IDENT_INT(SINT2'WIDTH) /= 4 THEN + FAILED ( "WRONG WIDTH FOR 'SINT2'" ); + END IF; + + IF IDENT_INT(SINT3'WIDTH) /= 4 THEN + FAILED ( "WRONG WIDTH FOR 'SINT3'" ); + END IF; + + IF IDENT_INT(NOINT'WIDTH) /= 0 THEN + FAILED ( "WRONG WIDTH FOR 'NOINT'" ); + END IF; + END; + + RESULT; +END C35503A; diff --git a/gcc-4.9/gcc/testsuite/ada/acats/tests/c3/c35503b.ada b/gcc-4.9/gcc/testsuite/ada/acats/tests/c3/c35503b.ada new file mode 100644 index 000000000..f1bb5af0b --- /dev/null +++ b/gcc-4.9/gcc/testsuite/ada/acats/tests/c3/c35503b.ada @@ -0,0 +1,87 @@ +-- C35503B.ADA + +-- Grant of Unlimited Rights +-- +-- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687, +-- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained +-- unlimited rights in the software and documentation contained herein. +-- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making +-- this public release, the Government intends to confer upon all +-- recipients unlimited rights equal to those held by the Government. +-- These rights include rights to use, duplicate, release or disclose the +-- released technical data and computer software in whole or in part, in +-- any manner and for any purpose whatsoever, and to have or permit others +-- to do so. +-- +-- DISCLAIMER +-- +-- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR +-- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED +-- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF 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 'WIDTH' YIELDS THE CORRECT RESULT WHEN THE PREFIX IS A +-- GENERIC FORMAL DISCRETE TYPE WHOSE ACTUAL PARAMETER IS AN INTEGER +-- TYPE. + +-- RJW 3/17/86 + +WITH REPORT; USE REPORT; + +PROCEDURE C35503B IS + +BEGIN + TEST ("C35503B", "CHECK THAT 'WIDTH' YIELDS THE CORRECT " & + "RESULT WHEN THE PREFIX IS A GENERIC FORMAL " & + "DISCRETE TYPE WHOSE ACTUAL PARAMETER IS AN " & + "INTEGER TYPE" ); + + DECLARE + + TYPE INT IS RANGE -1000 .. 1000; + TYPE INT2 IS NEW INT RANGE 0E8 .. 1E3; + SUBTYPE SINT1 IS INT RANGE 00000 .. 300; + SUBTYPE SINT2 IS INT RANGE 16#E#E1 .. 2#1111_1111#; + + GENERIC + TYPE I IS (<>); + W : INTEGER; + PROCEDURE P (STR : STRING); + + PROCEDURE P (STR : STRING) IS + SUBTYPE SUBI IS I + RANGE I'VAL (IDENT_INT(224)) .. I'VAL (255); + SUBTYPE NORANGE IS I + RANGE I'VAL (255) .. I'VAL (IDENT_INT(224)); + BEGIN + IF IDENT_INT(I'WIDTH) /= W THEN + FAILED ( "INCORRECT I'WIDTH FOR " & STR ); + END IF; + + IF IDENT_INT(SUBI'WIDTH) /= 4 THEN + FAILED ( "INCORRECT SUBI'WIDTH FOR " & STR ); + END IF; + + IF IDENT_INT(NORANGE'WIDTH) /= 0 THEN + FAILED ( "INCORRECT NORANGE'WIDTH FOR " & STR ); + END IF; + END P; + + PROCEDURE P_INTEGER IS NEW P (INTEGER, INTEGER'WIDTH); + PROCEDURE P_INT IS NEW P (INT, 5); + PROCEDURE P_INT2 IS NEW P (INT2, 5); + PROCEDURE P_SINT1 IS NEW P (SINT1, 4); + PROCEDURE P_SINT2 IS NEW P (SINT2, 4); + + BEGIN + P_INTEGER ("'INTEGER'"); + P_INT ("'INT'"); + P_INT2 ("'INT2'"); + P_SINT1 ("'SINT1'"); + P_SINT2 ("'SINT2'"); + END; + + RESULT; +END C35503B; diff --git a/gcc-4.9/gcc/testsuite/ada/acats/tests/c3/c35503c.ada b/gcc-4.9/gcc/testsuite/ada/acats/tests/c3/c35503c.ada new file mode 100644 index 000000000..331c76cc4 --- /dev/null +++ b/gcc-4.9/gcc/testsuite/ada/acats/tests/c3/c35503c.ada @@ -0,0 +1,543 @@ +-- C35503C.ADA + +-- Grant of Unlimited Rights +-- +-- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687, +-- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained +-- unlimited rights in the software and documentation contained herein. +-- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making +-- this public release, the Government intends to confer upon all +-- recipients unlimited rights equal to those held by the Government. +-- These rights include rights to use, duplicate, release or disclose the +-- released technical data and computer software in whole or in part, in +-- any manner and for any purpose whatsoever, and to have or permit others +-- to do so. +-- +-- DISCLAIMER +-- +-- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR +-- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED +-- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF 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 'IMAGE' AND 'VALUE' YIELD THE CORRECT RESULTS WHEN +-- THE PREFIX IS AN INTEGER TYPE. +-- SUBTESTS ARE : +-- PART (A). TESTS FOR 'IMAGE'. +-- PART (B). TESTS FOR 'VALUE'. + +-- HISTORY: +-- RJW 03/17/86 CREATED ORIGINAL TEST. +-- VCL 10/23/87 MODIFIED THIS HEADER, ADDED A CHECK THAT +-- CONSTRAINT_ERROR IS RAISED FOR THE ATTRIBUTE +-- 'VALUE' IF THE FINAL SHARP OR COLON IS MISSING +-- FROM A BASED LITERAL. + +WITH REPORT; USE REPORT; +PROCEDURE C35503C IS + TYPE NEWINT IS NEW INTEGER; + TYPE INT IS RANGE -1000 .. 1000; + + FUNCTION IDENT (X : INT) RETURN INT IS + BEGIN + IF EQUAL (INT'POS (X), INT'POS(X)) THEN + RETURN X; + END IF; + RETURN INT'FIRST; + END IDENT; + +BEGIN + TEST ("C35503C", "THE ATTIBUTES 'IMAGE' AND 'VALUE' YIELD THE " & + "CORRECT RESULTS WHEN THE PREFIX IS AN " & + "INTEGER TYPE" ); +-- PART (A). + + BEGIN + IF INTEGER'IMAGE (-500) /= "-500" THEN + FAILED ( "INCORRECT 'IMAGE' OF '-500'" ); + END IF; + IF INTEGER'IMAGE (-500)'FIRST /= 1 THEN + FAILED ( "INCORRECT LOWER BOUND FOR '-500'" ); + END IF; + + IF NEWINT'IMAGE (2 ** 6) /= " 64" THEN + FAILED ( "INCORRECT 'IMAGE' OF '2 ** 6'" ); + END IF; + IF NEWINT'IMAGE (2 ** 6)'FIRST /= 1 THEN + FAILED ( "INCORRECT LOWER BOUND FOR '2 ** 6'" ); + END IF; + + IF NATURAL'IMAGE (-1E2) /= "-100" THEN + FAILED ( "INCORRECT 'IMAGE' OF '-1E2'" ); + END IF; + IF NATURAL'IMAGE (-1E2)'FIRST /= 1 THEN + FAILED ( "INCORRECT LOWER BOUND FOR '-1E2'" ); + END IF; + + IF NEWINT'IMAGE (3_45) /= " 345" THEN + FAILED ( "INCORRECT 'IMAGE' OF '3_45'" ); + END IF; + IF NEWINT'IMAGE (3_45)'FIRST /= 1 THEN + FAILED ( "INCORRECT LOWER BOUND FOR '3_45'" ); + END IF; + + IF INTEGER'IMAGE (-2#1111_1111#) /= "-255" THEN + FAILED ( "INCORRECT 'IMAGE' OF '-2#1111_1111#'" ); + END IF; + IF INTEGER'IMAGE (-2#1111_1111#)'FIRST /= 1 THEN + FAILED ( "INCORRECT LOWER BOUND FOR '-2#1111_1111#'" ); + END IF; + + IF NEWINT'IMAGE (16#FF#) /= " 255" THEN + FAILED ( "INCORRECT 'IMAGE' OF '16#FF#'" ); + END IF; + IF NEWINT'IMAGE (16#FF#)'FIRST /= 1 THEN + FAILED ( "INCORRECT LOWER BOUND FOR '16#FF#'" ); + END IF; + + IF INTEGER'IMAGE (-016#0FF#) /= "-255" THEN + FAILED ( "INCORRECT 'IMAGE' OF '-016#0FF#'" ); + END IF; + IF INTEGER'IMAGE (-016#0FF#)'FIRST /= 1 THEN + FAILED ( "INCORRECT LOWER BOUND FOR '-016#0FF#'" ); + END IF; + + IF NEWINT'IMAGE (2#1110_0000#) /= " 224" THEN + FAILED ( "INCORRECT 'IMAGE' OF '2#1110_0000#'" ); + END IF; + IF NEWINT'IMAGE (2#1110_0000#)'FIRST /= 1 THEN + FAILED ( "INCORRECT LOWER BOUND FOR '2#1110_0000#'" ); + END IF; + + IF POSITIVE'IMAGE (-16#E#E1) /= "-224" THEN + FAILED ( "INCORRECT 'IMAGE' OF '-16#E#E1'" ); + END IF; + IF POSITIVE'IMAGE (-16#E#E1)'FIRST /= 1 THEN + FAILED ( "INCORRECT LOWER BOUND FOR '-16#E#E1'" ); + END IF; + + IF INT'IMAGE (IDENT(-1000)) /= "-1000" THEN + FAILED ( "INCORRECT 'IMAGE' OF '-1000'" ); + END IF; + IF INT'IMAGE (IDENT(-1000))'FIRST /= 1 THEN + FAILED ( "INCORRECT LOWER BOUND FOR '-1000'" ); + END IF; + + IF INT'IMAGE (IDENT(-999)) /= "-999" THEN + FAILED ( "INCORRECT 'IMAGE' OF '-999'" ); + END IF; + IF INT'IMAGE (IDENT(-999))'FIRST /= 1 THEN + FAILED ( "INCORRECT LOWER BOUND FOR '-999'" ); + END IF; + + IF INT'IMAGE (IDENT(-10)) /= "-10" THEN + FAILED ( "INCORRECT 'IMAGE' OF '-1000'" ); + END IF; + IF INT'IMAGE (IDENT(-10))'FIRST /= 1 THEN + FAILED ( "INCORRECT LOWER BOUND FOR '-10'" ); + END IF; + + IF INT'IMAGE (IDENT(-9)) /= "-9" THEN + FAILED ( "INCORRECT 'IMAGE' OF '-9'" ); + END IF; + IF INT'IMAGE (IDENT(-9))'FIRST /= 1 THEN + FAILED ( "INCORRECT LOWER BOUND FOR '-9'" ); + END IF; + + IF INT'IMAGE (IDENT(-1)) /= "-1" THEN + FAILED ( "INCORRECT 'IMAGE' OF '-1'" ); + END IF; + IF INT'IMAGE (IDENT(-1))'FIRST /= 1 THEN + FAILED ( "INCORRECT LOWER BOUND FOR '-1'" ); + END IF; + + IF INT'IMAGE (IDENT(0)) /= " 0" THEN + FAILED ( "INCORRECT 'IMAGE' OF '0'" ); + END IF; + IF INT'IMAGE (IDENT(0))'FIRST /= 1 THEN + FAILED ( "INCORRECT LOWER BOUND FOR '0'" ); + END IF; + + IF INT'IMAGE (IDENT(1)) /= " 1" THEN + FAILED ( "INCORRECT 'IMAGE' OF '1'" ); + END IF; + IF INT'IMAGE (IDENT(1))'FIRST /= 1 THEN + FAILED ( "INCORRECT LOWER BOUND FOR '1'" ); + END IF; + + IF INT'IMAGE (IDENT(9)) /= " 9" THEN + FAILED ( "INCORRECT 'IMAGE' OF '9'" ); + END IF; + IF INT'IMAGE (IDENT(9))'FIRST /= 1 THEN + FAILED ( "INCORRECT LOWER BOUND FOR '9'" ); + END IF; + + IF INT'IMAGE (IDENT(10)) /= " 10" THEN + FAILED ( "INCORRECT 'IMAGE' OF '10'" ); + END IF; + IF INT'IMAGE (IDENT(10))'FIRST /= 1 THEN + FAILED ( "INCORRECT LOWER BOUND FOR '10'" ); + END IF; + + IF INT'IMAGE (IDENT(999)) /= " 999" THEN + FAILED ( "INCORRECT 'IMAGE' OF '999'" ); + END IF; + IF INT'IMAGE (IDENT(999))'FIRST /= 1 THEN + FAILED ( "INCORRECT LOWER BOUND FOR '999'" ); + END IF; + + IF INT'IMAGE (IDENT(1000)) /= " 1000" THEN + FAILED ( "INCORRECT 'IMAGE' OF '1000'" ); + END IF; + IF INT'IMAGE (IDENT(1000))'FIRST /= 1 THEN + FAILED ( "INCORRECT LOWER BOUND FOR '1000'" ); + END IF; + + END; + +----------------------------------------------------------------------- + +-- PART (B). + + BEGIN + IF POSITIVE'VALUE (IDENT_STR("-500")) /= -500 THEN + FAILED ( "INCORRECT 'VALUE' OF ""-500""" ); + END IF; + EXCEPTION + WHEN OTHERS => + FAILED ( "EXCEPTION RAISED - 'VALUE' OF ""-500""" ); + END; + + BEGIN + IF NEWINT'VALUE (" -001E2") /= -100 THEN + FAILED ( "INCORRECT 'VALUE' OF "" -001E2""" ); + END IF; + EXCEPTION + WHEN OTHERS => + FAILED ( "EXCEPTION RAISED - 'VALUE' OF "" -001E2""" ); + END; + + BEGIN + IF INTEGER'VALUE ("03_45") /= 345 THEN + FAILED ( "INCORRECT 'VALUE' OF ""03_45""" ); + END IF; + EXCEPTION + WHEN OTHERS => + FAILED ( "EXCEPTION RAISED - 'VALUE' OF ""03_45""" ); + END; + + BEGIN + IF NEWINT'VALUE ("-2#1111_1111#") /= -255 THEN + FAILED ( "INCORRECT 'VALUE' OF ""-2#1111_1111#""" ); + END IF; + EXCEPTION + WHEN OTHERS => + FAILED ( "EXCEPTION RAISED - 'VALUE' OF "& + """-2#1111_1111#""" ); + END; + + BEGIN + IF INTEGER'VALUE (IDENT_STR("16#FF#")) /= 255 THEN + FAILED ( "INCORRECT 'VALUE' OF ""16#FF#""" ); + END IF; + EXCEPTION + WHEN OTHERS => + FAILED ( "EXCEPTION RAISED - 'VALUE' OF ""16#FF#""" ); + END; + + BEGIN + IF NATURAL'VALUE (IDENT_STR("-016#0FF#")) /= -255 THEN + FAILED ( "INCORRECT 'VALUE' OF ""-016#0FF#""" ); + END IF; + EXCEPTION + WHEN OTHERS => + FAILED ( "EXCEPTION RAISED - 'VALUE' OF " & + """-016#0FF#""" ); + END; + + BEGIN + IF INTEGER'VALUE ("2#1110_0000# ") /= 224 THEN + FAILED ( "INCORRECT 'VALUE' OF " & + """2#1110_0000# """ ); + END IF; + EXCEPTION + WHEN OTHERS => + FAILED ( "EXCEPTION RAISED - 'VALUE' OF " & + """2#1110_0000# """ ); + END; + + BEGIN + IF NEWINT'VALUE (" -16#E#E1") /= -224 THEN + FAILED ( "INCORRECT 'VALUE' OF "" -16#E#E1""" ); + END IF; + EXCEPTION + WHEN OTHERS => + FAILED ( "EXCEPTION RAISED - 'VALUE' OF " & + """ -16#E#E1""" ); + END; + + BEGIN + IF INTEGER'VALUE ("5/0") = 0 THEN + FAILED ( "NO EXCEPTION RAISED - ""5/0"" - 1" ); + ELSE + FAILED ( "NO EXCEPTION RAISED - ""5/0"" - 2" ); + END IF; + EXCEPTION + WHEN CONSTRAINT_ERROR => + NULL; + WHEN OTHERS => + FAILED ( "WRONG EXCEPTION RAISED - ""5/0""" ); + END; + + DECLARE + SUBTYPE SUBINT IS INTEGER RANGE 0 .. 10; + BEGIN + IF SUBINT'VALUE (IDENT_STR("-500")) /= -500 THEN + FAILED ( "INCORRECT VALUE WITH ""-500"" AND SUBINT" ); + END IF; + EXCEPTION + WHEN OTHERS => + FAILED ( "EXCEPTION RAISED - SUBINT" ); + END; + + BEGIN + IF INTEGER'VALUE (IDENT_STR("1.0")) = 1 THEN + FAILED ( "NO EXCEPTION RAISED - "" 1.0"" - 1" ); + ELSE + FAILED ( "NO EXCEPTION RAISED - ""1.0"" - 2" ); + END IF; + EXCEPTION + WHEN CONSTRAINT_ERROR => + NULL; + WHEN OTHERS => + FAILED ( "WRONG EXCEPTION RAISED - ""1.0"" " ); + END; + + BEGIN + IF INTEGER'VALUE (IDENT_CHAR(ASCII.HT) & "244") /= 244 THEN + FAILED ( "NO EXCEPTION RAISED - LEADING 'HT' - 1" ); + ELSE + FAILED ( "NO EXCEPTION RAISED - LEADING 'HT' - 2" ); + END IF; + EXCEPTION + WHEN CONSTRAINT_ERROR => + NULL; + WHEN OTHERS => + FAILED ( "WRONG EXCEPTION RAISED - LEADING 'HT'" ); + END; + + BEGIN + IF INTEGER'VALUE ("244" & (IDENT_CHAR(ASCII.HT))) /= 244 THEN + FAILED ( "NO EXCEPTION RAISED - TRAILING 'HT' - 1" ); + ELSE + FAILED ( "NO EXCEPTION RAISED - TRAILING 'HT' - 2" ); + END IF; + EXCEPTION + WHEN CONSTRAINT_ERROR => + NULL; + WHEN OTHERS => + FAILED ( "WRONG EXCEPTION RAISED - TRAILING 'HT'" ); + END; + + BEGIN + IF INTEGER'VALUE (IDENT_STR("2__44")) /= 244 THEN + FAILED ( "NO EXCEPTION RAISED - CONSECUTIVE '_' - 1" ); + ELSE + FAILED ( "NO EXCEPTION RAISED - CONSECUTIVE '_' - 2" ); + END IF; + EXCEPTION + WHEN CONSTRAINT_ERROR => + NULL; + WHEN OTHERS => + FAILED ( "WRONG EXCEPTION RAISED " & + "WITH CONSECUTIVE '_'" ); + END; + + BEGIN + IF INTEGER'VALUE (IDENT_STR("_244")) /= 244 THEN + FAILED ( "NO EXCEPTION RAISED - LEADING '_' - 1" ); + ELSE + FAILED ( "NO EXCEPTION RAISED - LEADING '_' - 2" ); + END IF; + EXCEPTION + WHEN CONSTRAINT_ERROR => + NULL; + WHEN OTHERS => + FAILED ( "WRONG EXCEPTION RAISED - LEADING '_'" ); + END; + + BEGIN + IF INTEGER'VALUE (IDENT_STR("244_")) /= 244 THEN + FAILED ( "NO EXCEPTION RAISED - TRAILING '_' - 1" ); + ELSE + FAILED ( "NO EXCEPTION RAISED - TRAILING '_' - 2" ); + END IF; + EXCEPTION + WHEN CONSTRAINT_ERROR => + NULL; + WHEN OTHERS => + FAILED ( "WRONG EXCEPTION RAISED - TRAILING '_'" ); + END; + + BEGIN + IF INTEGER'VALUE (IDENT_STR("244_E1")) /= 2440 THEN + FAILED ( "NO EXCEPTION RAISED - '_' BEFORE 'E' - 1" ); + ELSE + FAILED ( "NO EXCEPTION RAISED - '_' BEFORE 'E' - 2" ); + END IF; + EXCEPTION + WHEN CONSTRAINT_ERROR => + NULL; + WHEN OTHERS => + FAILED ( "WRONG EXCEPTION RAISED - '_' BEFORE 'E'" ); + END; + + BEGIN + IF INTEGER'VALUE (IDENT_STR("244E_1")) /= 2440 THEN + FAILED ( "NO EXCEPTION RAISED - '_' " & + "FOLLOWING 'E' - 1" ); + ELSE + FAILED ( "NO EXCEPTION RAISED - '_' FOLLOWING 'E' - 2" ); + END IF; + EXCEPTION + WHEN CONSTRAINT_ERROR => + NULL; + WHEN OTHERS => + FAILED ( "WRONG EXCEPTION RAISED " & + "- '_' FOLLOWING 'E'" ); + END; + + BEGIN + IF INTEGER'VALUE (IDENT_STR("244_e1")) /= 2440 THEN + FAILED ( "NO EXCEPTION RAISED - '_' BEFORE 'e' - 1" ); + ELSE + FAILED ( "NO EXCEPTION RAISED - '_' BEFORE 'e' - 2" ); + END IF; + EXCEPTION + WHEN CONSTRAINT_ERROR => + NULL; + WHEN OTHERS => + FAILED ( "WRONG EXCEPTION RAISED - '_' BEFORE 'e'" ); + END; + + BEGIN + IF INTEGER'VALUE (IDENT_STR("16#_FF#")) /= 255 THEN + FAILED ( "NO EXCEPTION RAISED - LEADING '_' IN BASED " & + "LITERAL - 1" ); + ELSE + FAILED ( "NO EXCEPTION RAISED - LEADING '_' IN BASED " & + "LITERAL - 2" ); + END IF; + EXCEPTION + WHEN CONSTRAINT_ERROR => + NULL; + WHEN OTHERS => + FAILED ( "WRONG EXCEPTION RAISED " & + "- LEADING '_' IN BASED LITERAL" ); + END; + + BEGIN + IF INTEGER'VALUE (IDENT_STR("1E-0")) /= 1 THEN + FAILED ( "NO EXCEPTION RAISED - NEGATIVE " & + "EXPONENT - 1" ); + ELSE + FAILED ( "NO EXCEPTION RAISED - NEGATIVE EXPONENT - 2" ); + END IF; + EXCEPTION + WHEN CONSTRAINT_ERROR => + NULL; + WHEN OTHERS => + FAILED ( "WRONG EXCEPTION RAISED " & + "- NEGATIVE EXPONENT" ); + END; + + BEGIN + IF INTEGER'VALUE (IDENT_STR("244.")) /= 244 THEN + FAILED ( "NO EXCEPTION RAISED - TRAILING '.' - 1" ); + ELSE + FAILED ( "NO EXCEPTION RAISED - TRAILING '.' - 2" ); + END IF; + EXCEPTION + WHEN CONSTRAINT_ERROR => + NULL; + WHEN OTHERS => + FAILED ( "WRONG EXCEPTION RAISED - TRAILING '.'" ); + END; + + BEGIN + IF INTEGER'VALUE (IDENT_STR("8#811#")) /= 0 THEN + FAILED ( "NO EXCEPTION RAISED - " & + "DIGITS NOT IN CORRECT RANGE - 1" ); + ELSE + FAILED ( "NO EXCEPTION RAISED - " & + "DIGITS NOT IN CORRECT RANGE - 2" ); + END IF; + EXCEPTION + WHEN CONSTRAINT_ERROR => + NULL; + WHEN OTHERS => + FAILED ( "WRONG EXCEPTION RAISED - " & + "DIGITS NOT IN CORRECT RANGE" ); + END; + + BEGIN + IF INTEGER'VALUE (IDENT_STR("1#000#")) /= 0 THEN + FAILED ( "NO EXCEPTION RAISED - BASE LESS THAN 2 - 1" ); + ELSE + FAILED ( "NO EXCEPTION RAISED - BASE LESS THAN 2 - 2" ); + END IF; + EXCEPTION + WHEN CONSTRAINT_ERROR => + NULL; + WHEN OTHERS => + FAILED ( "WRONG EXCEPTION RAISED " & + "- BASE LESS THAN 2" ); + END; + + BEGIN + IF INTEGER'VALUE (IDENT_STR("17#0#")) /= 0 THEN + FAILED ( "NO EXCEPTION RAISED " & + "- BASE GREATER THAN 16 - 1" ); + ELSE + FAILED ( "NO EXCEPTION RAISED " & + "- BASE GREATER THAN 16 - 2" ); + END IF; + EXCEPTION + WHEN CONSTRAINT_ERROR => + NULL; + WHEN OTHERS => + FAILED ( "WRONG EXCEPTION RAISED " & + "- BASE GREATER THAN 16" ); + END; + + BEGIN + IF INTEGER'VALUE (IDENT_STR("8#666")) /= 438 THEN + FAILED ("NO EXCEPTION RAISED - MISSING FINAL SHARP - 1"); + ELSE + FAILED ("NO EXCEPTION RAISED - MISSING FINAL SHARP - 2"); + END IF; + EXCEPTION + WHEN CONSTRAINT_ERROR => + NULL; + WHEN OTHERS => + FAILED ("WRONG EXCEPTION RAISED - MISSING FINAL SHARP"); + END; + + BEGIN + IF INTEGER'VALUE (IDENT_STR("16:FF")) /= 255 THEN + FAILED ("NO EXCEPTION RAISED - MISSING FINAL COLON - 1"); + ELSE + FAILED ("NO EXCEPTION RAISED - MISSING FINAL COLON - 2"); + END IF; + EXCEPTION + WHEN CONSTRAINT_ERROR => + NULL; + WHEN OTHERS => + FAILED ("WRONG EXCEPTION RAISED - MISSING FINAL COLON"); + END; + + RESULT; +END C35503C; diff --git a/gcc-4.9/gcc/testsuite/ada/acats/tests/c3/c35503d.tst b/gcc-4.9/gcc/testsuite/ada/acats/tests/c3/c35503d.tst new file mode 100644 index 000000000..b15e1ab0f --- /dev/null +++ b/gcc-4.9/gcc/testsuite/ada/acats/tests/c3/c35503d.tst @@ -0,0 +1,97 @@ +-- C35503D.TST + +-- Grant of Unlimited Rights +-- +-- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687, +-- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained +-- unlimited rights in the software and documentation contained herein. +-- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making +-- this public release, the Government intends to confer upon all +-- recipients unlimited rights equal to those held by the Government. +-- These rights include rights to use, duplicate, release or disclose the +-- released technical data and computer software in whole or in part, in +-- any manner and for any purpose whatsoever, and to have or permit others +-- to do so. +-- +-- DISCLAIMER +-- +-- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR +-- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED +-- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE +-- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE +-- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A +-- PARTICULAR PURPOSE OF SAID MATERIAL. +--* +-- OBJECTIVE: +-- CHECK THAT 'IMAGE' AND 'VALUE' YIELD THE CORRECT RESULT FOR THE +-- LARGEST/SMALLEST INTEGER LITERAL FOR THE LONGEST INTEGER TYPE. + +-- HISTORY: +-- RJW 02/26/86 CREATED ORIGINAL TEST. +-- DHH 10/19/87 SHORTENED LINES CONTAINING MORE THAN 72 CHARACTERS. + +WITH SYSTEM; USE SYSTEM; +WITH REPORT; USE REPORT; + +PROCEDURE C35503D IS + + TYPE INT IS RANGE MIN_INT .. MAX_INT; + + FUNCTION IDENT (X:INT) RETURN INT IS + BEGIN + IF EQUAL (3,3) THEN + RETURN X; + END IF; + RETURN 0; + END IDENT; + +BEGIN + TEST ("C35503D", "CHECK THAT 'IMAGE' AND 'VALUE' YIELD " & + "CORRECT RESULTS FOR THE LARGEST/SMALLEST "& + "INTEGER LITERAL FOR THE LARGEST INTEGER TYPE"); + + -- MIN_INT IS THE DECIMAL LITERAL FOR SYSTEM.MIN_INT. + -- MAX_INT IS THE DECIMAL LITERAL FOR SYSTEM.MAX_INT. + + BEGIN + IF INT'VALUE (IDENT_STR("$MIN_INT")) /= MIN_INT THEN + FAILED("INCORRECT RESULTS FOR 'VALUE' - MIN_INT"); + END IF; + EXCEPTION + WHEN CONSTRAINT_ERROR => + FAILED("CONSTRAINT_ERROR RAISED FOR 'VALUE' - MIN_INT"); + WHEN OTHERS => + FAILED("OTHER EXCEPTION RAISED FOR 'VALUE' - MIN_INT"); + END; + + BEGIN + IF INT'IMAGE (IDENT(MIN_INT)) /= "$MIN_INT" THEN + FAILED("INCORRECT RESULTS FOR 'IMAGE' - MIN_INT"); + END IF; + EXCEPTION + WHEN OTHERS => + FAILED("EXCEPTION RAISED FOR 'IMAGE' - MIN_INT"); + END; + + BEGIN + IF INT'VALUE (IDENT_STR("$MAX_INT")) /= MAX_INT THEN + FAILED("INCORRECT RESULTS FOR 'VALUE' - MAX_INT"); + END IF; + EXCEPTION + WHEN CONSTRAINT_ERROR => + FAILED("CONSTRAINT_ERROR RAISED FOR 'VALUE' - MAX_INT"); + WHEN OTHERS => + FAILED("OTHER EXCEPTION RAISED FOR 'VALUE' - MAX_INT"); + END; + + BEGIN + IF INT'IMAGE (IDENT(MAX_INT)) /= ' ' & "$MAX_INT" THEN + FAILED("INCORRECT RESULTS FOR 'IMAGE' - MAXINT"); + END IF; + EXCEPTION + WHEN OTHERS => + FAILED("EXCEPTION RAISED FOR 'IMAGE' - MAXINT"); + END; + + RESULT; +END C35503D; diff --git a/gcc-4.9/gcc/testsuite/ada/acats/tests/c3/c35503e.ada b/gcc-4.9/gcc/testsuite/ada/acats/tests/c3/c35503e.ada new file mode 100644 index 000000000..0f326e1e5 --- /dev/null +++ b/gcc-4.9/gcc/testsuite/ada/acats/tests/c3/c35503e.ada @@ -0,0 +1,212 @@ +-- C35503E.ADA + +-- Grant of Unlimited Rights +-- +-- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687, +-- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained +-- unlimited rights in the software and documentation contained herein. +-- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making +-- this public release, the Government intends to confer upon all +-- recipients unlimited rights equal to those held by the Government. +-- These rights include rights to use, duplicate, release or disclose the +-- released technical data and computer software in whole or in part, in +-- any manner and for any purpose whatsoever, and to have or permit others +-- to do so. +-- +-- DISCLAIMER +-- +-- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR +-- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED +-- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF 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 'IMAGE' AND 'VALUE' YIELD THE CORRECT RESULTS WHEN +-- THE PREFIX IS A GENERIC FORMAL DISCRETE TYPE WHOSE ACTUAL +-- PARAMETER IS AN INTEGER TYPE. +-- SUBTESTS ARE : +-- PART (A). TESTS FOR 'IMAGE'. +-- PART (B). TESTS FOR 'VALUE'. + +-- HISTORY: +-- RJW 03/17/86 CREATED ORIGINAL TEST. +-- DHH 10/19/87 SHORTENED LINES CONTAINING MORE THAN 72 CHARACTERS. + +WITH REPORT; USE REPORT; + +PROCEDURE C35503E IS + +BEGIN + TEST ("C35503E", "CHECK THAT 'IMAGE' AND 'VALUE' YIELD THE " & + "CORRECT RESULTS WHEN THE PREFIX IS A " & + "GENERIC FORMAL DISCRETE TYPE WHOSE ACTUAL " & + "PARAMETER IS AN INTEGER TYPE" ); +-- PART (A). + + DECLARE + TYPE NEWINT IS NEW INTEGER RANGE -2000 .. 2000; + + GENERIC + TYPE INT IS (<>); + PROCEDURE P (I1 : INT; STR : STRING ); + + PROCEDURE P (I1 : INT; STR : STRING) IS + SUBTYPE SUBINT IS INT + RANGE INT'VAL (IDENT_INT(-1000)) .. + INT'VAL (IDENT_INT(1000)); + BEGIN + + IF INT'IMAGE (I1) /= STR THEN + FAILED ( "INCORRECT INT'IMAGE OF " & STR ); + END IF; + IF INT'IMAGE (I1)'FIRST /= 1 THEN + FAILED ( "INCORRECT LOWER BOUND FOR INT'IMAGE OF " & + STR ); + END IF; + + IF SUBINT'IMAGE (I1) /= STR THEN + FAILED ( "INCORRECT SUBINT'IMAGE OF " & STR ); + END IF; + IF SUBINT'IMAGE (I1)'FIRST /= 1 THEN + FAILED ( "INCORRECT LOWER BOUND FOR SUBINT'IMAGE " & + "OF " & STR ); + END IF; + + END P; + + PROCEDURE PROC1 IS NEW P (INTEGER); + PROCEDURE PROC2 IS NEW P (NEWINT); + + BEGIN + PROC1 (-500, "-500"); + PROC2 (0, " 0"); + PROC2 (99," 99"); + END; + +----------------------------------------------------------------------- + +-- PART (B). + + DECLARE + TYPE NEWINT IS NEW INTEGER; + + GENERIC + TYPE INT IS (<>); + PROCEDURE P (STR : STRING; I1 : INT ); + + PROCEDURE P (STR : STRING; I1 : INT) IS + SUBTYPE SUBINT IS INT + RANGE INT'VAL (IDENT_INT(0)) .. + INT'VAL (IDENT_INT(10)); + + BEGIN + BEGIN + IF INT'VALUE (STR) /= I1 THEN + FAILED ( "INCORRECT INT'VALUE OF """ & + STR & """"); + END IF; + EXCEPTION + WHEN OTHERS => + FAILED ( "EXCEPTION RAISED INT'VALUE OF """ & + STR & """"); + END; + BEGIN + IF SUBINT'VALUE (STR) /= I1 THEN + FAILED ( "INCORRECT SUBINT'VALUE OF """ & + STR & """"); + END IF; + EXCEPTION + WHEN OTHERS => + FAILED ( "EXCEPTION RAISED SUBINT'VALUE " & + "OF """ & STR & """"); + END; + END P; + + PROCEDURE PROC1 IS NEW P (INTEGER); + PROCEDURE PROC2 IS NEW P (NEWINT); + + BEGIN + PROC1 ("-500" , -500); + PROC2 (" -001E2 " , -100); + PROC1 ("3_45" , 345); + PROC2 ("-2#1111_1111#" , -255); + PROC1 ("16#FF#" , 255); + PROC2 ("-016#0FF#" , -255); + PROC1 ("2#1110_0000# " , 224); + PROC2 ("-16#E#E1" , -224); + + END; + + DECLARE + TYPE NEWINT IS NEW INTEGER; + + GENERIC + TYPE INT IS (<>); + PROCEDURE P (STR1 : STRING; I1 : INT; STR2 : STRING); + + PROCEDURE P (STR1 : STRING; I1 : INT; STR2 : STRING) IS + SUBTYPE SUBINT IS INT + RANGE INT'VAL (IDENT_INT(0)) .. + INT'VAL (IDENT_INT(10)); + + BEGIN + BEGIN + IF INT'VALUE (STR1) = I1 THEN + FAILED ( "NO EXCEPTION RAISED - INT'VALUE " & + "WITH " & STR2 & " - EQUAL"); + ELSE + FAILED ( "NO EXCEPTION RAISED " & + "- INT'VALUE WITH " & + STR2 & " - NOT EQUAL" ); + END IF; + EXCEPTION + WHEN CONSTRAINT_ERROR => + NULL; + WHEN OTHERS => + FAILED ( "WRONG EXCEPTION RAISED - " & + "INT'VALUE WITH " & STR2 ); + END; + BEGIN + IF SUBINT'VALUE (STR1) = I1 THEN + FAILED ( "NO EXCEPTION RAISED - " & + "SUBINT'VALUE WITH " & STR2 + & " - EQUAL" ); + ELSE + FAILED ( "NO EXCEPTION RAISED - " & + "SUBINT'VALUE WITH " & + STR2 & " - NOT EQUAL" ); + END IF; + EXCEPTION + WHEN CONSTRAINT_ERROR => + NULL; + WHEN OTHERS => + FAILED ( "WRONG EXCEPTION RAISED - " & + "SUBINT'VALUE WITH " & STR2 ); + END; + END P; + + PROCEDURE PROC1 IS NEW P (INTEGER); + PROCEDURE PROC2 IS NEW P (NEWINT); + + BEGIN + PROC1 ("1.0" , 1, "DECIMAL POINT"); + PROC1 (ASCII.HT & "244", 244, "LEADING 'HT'" ); + PROC2 ("244" & ASCII.HT, 244, "TRAILING 'HT'" ); + PROC1 ("2__44" , 244, "CONSECUTIVE '_'" ); + PROC2 ("_244" , 244, "LEADING '_'" ); + PROC1 ("244_" , 244, "TRAILING '_'" ); + PROC2 ("244_E1" , 2440, "'_' BEFORE 'E'" ); + PROC1 ("244E_1" , 2440, "'_' FOLLOWING 'E'" ); + PROC2 ("244_e1" , 2440, "'_' BEFORE 'e'" ); + PROC1 ("16#_FF#" , 255, "'_' IN BASED LITERAL" ); + PROC2 ("1E-0" , 0, "NEGATIVE EXPONENT" ); + PROC1 ("244." , 244, "TRAILING '.'" ); + PROC2 ("8#811#" , 0, "DIGITS OUTSIDE OF RANGE" ); + PROC1 ("1#000#" , 0, "BASE LESS THAN 2" ); + PROC2 ("17#0#" , 0, "BASE GREATER THAN 16" ); + END; + + RESULT; +END C35503E; diff --git a/gcc-4.9/gcc/testsuite/ada/acats/tests/c3/c35503f.tst b/gcc-4.9/gcc/testsuite/ada/acats/tests/c3/c35503f.tst new file mode 100644 index 000000000..f68669aaf --- /dev/null +++ b/gcc-4.9/gcc/testsuite/ada/acats/tests/c3/c35503f.tst @@ -0,0 +1,132 @@ +-- C35503F.TST + +-- Grant of Unlimited Rights +-- +-- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687, +-- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained +-- unlimited rights in the software and documentation contained herein. +-- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making +-- this public release, the Government intends to confer upon all +-- recipients unlimited rights equal to those held by the Government. +-- These rights include rights to use, duplicate, release or disclose the +-- released technical data and computer software in whole or in part, in +-- any manner and for any purpose whatsoever, and to have or permit others +-- to do so. +-- +-- DISCLAIMER +-- +-- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR +-- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED +-- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE +-- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE +-- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A +-- PARTICULAR PURPOSE OF SAID MATERIAL. +--* +-- OBJECTIVE: +-- CHECK THAT 'IMAGE' AND 'VALUE' YIELD THE CORRECT RESULT FOR THE +-- LARGEST/SMALLEST INTEGER LITERAL AND A FORMAL DISCRETE TYPE WHOSE +-- ACTUAL PARAMETER IS AN INTEGER TYPE. + +-- HISTORY +-- RJW 05/12/86 CREATED ORIGINAL TEST. +-- DHH 10/19/87 SHORTENED LINES CONTAINING MORE THAN 72 CHARACTERS. + +WITH SYSTEM; USE SYSTEM; +WITH REPORT; USE REPORT; + +PROCEDURE C35503F IS + +TYPE LONGEST_INT IS RANGE MIN_INT .. MAX_INT; + +BEGIN + TEST ("C35503F", "CHECK THAT 'IMAGE' AND 'VALUE' YIELD " & + "CORRECT RESULTS FOR THE LARGEST/SMALLEST "& + "INTEGER LITERAL AND A FORMAL DISCRETE TYPE " & + "WHOSE ACTUAL PARAMETER IS AN INTEGER TYPE"); + + -- INTEGER_FIRST IS THE DECIMAL LITERAL IMAGE OF INTEGER'FIRST. + -- INTEGER_LAST IS THE DECIMAL LITERAL IMAGE OF INTEGER'LAST. + -- MIN_INT IS THE DECIMAL LITERAL IMAGE OF SYSTEM.MIN_INT. + -- MAX_INT IS THE DECIMAL LITERAL IMAGE OF SYSTEM.MAX_INT. + + DECLARE + GENERIC + TYPE INT IS (<>); + PROCEDURE P ( FS, LS : STRING; FI, LI : INT ); + + PROCEDURE P ( FS, LS : STRING; FI, LI : INT ) IS + BEGIN + BEGIN + IF INT'VALUE (FS) /= FI THEN + FAILED ( "INCORRECT RESULTS FOR 'VALUE' OF " & + FS ); + END IF; + EXCEPTION + WHEN CONSTRAINT_ERROR => + FAILED ( "CONSTRAINT_ERROR RAISED FOR " & + "'VALUE' OF " & FS ); + WHEN OTHERS => + FAILED ( "OTHER EXCEPTION RAISED FOR " & + "'VALUE' OF " & FS ); + END; + + BEGIN + IF INT'VALUE (LS) /= LI THEN + FAILED ( "INCORRECT RESULTS FOR 'VALUE' OF " & + LS ); + END IF; + EXCEPTION + WHEN CONSTRAINT_ERROR => + FAILED ( "CONSTRAINT_ERROR RAISED FOR " & + "'VALUE' OF " & LS ); + WHEN OTHERS => + FAILED ( "OTHER EXCEPTION RAISED FOR " & + "'VALUE' OF " & LS ); + END; + END P; + + GENERIC + TYPE INT IS (<>); + PROCEDURE Q ( FS, LS : STRING; FI, LI : INT ); + + PROCEDURE Q ( FS, LS : STRING; FI, LI : INT ) IS + BEGIN + BEGIN + IF INT'IMAGE(FI) /= FS THEN + FAILED ( "INCORRECT RESULTS FOR " & + "'IMAGE' WITH " & FS ); + END IF; + EXCEPTION + WHEN OTHERS => + FAILED ( "EXCEPTION RAISED FOR 'IMAGE' " & + "WITH " & FS ); + END; + + BEGIN + IF INT'IMAGE(LI) /= LS THEN + FAILED ( "INCORRECT RESULTS FOR " & + "'IMAGE' WITH " & LS ); + END IF; + EXCEPTION + WHEN OTHERS => + FAILED ( "EXCEPTION RAISED FOR 'IMAGE' " & + "WITH " & LS ); + END; + END Q; + + PROCEDURE P1 IS NEW P ( INTEGER ); + PROCEDURE Q1 IS NEW Q ( INTEGER ); + PROCEDURE P2 IS NEW P ( LONGEST_INT ); + PROCEDURE Q2 IS NEW Q ( LONGEST_INT ); + BEGIN + P1 ("$INTEGER_FIRST", "$INTEGER_LAST", INTEGER'FIRST, + INTEGER'LAST); + P2 ("$MIN_INT", "$MAX_INT", MIN_INT, MAX_INT); + Q1 ("$INTEGER_FIRST"," $INTEGER_LAST", INTEGER'FIRST, + INTEGER'LAST); + Q2 ("$MIN_INT", " $MAX_INT", MIN_INT, MAX_INT); + + END; + + RESULT; +END C35503F; diff --git a/gcc-4.9/gcc/testsuite/ada/acats/tests/c3/c35503g.ada b/gcc-4.9/gcc/testsuite/ada/acats/tests/c3/c35503g.ada new file mode 100644 index 000000000..2004e457a --- /dev/null +++ b/gcc-4.9/gcc/testsuite/ada/acats/tests/c3/c35503g.ada @@ -0,0 +1,113 @@ +-- C35503G.ADA + +-- Grant of Unlimited Rights +-- +-- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687, +-- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained +-- unlimited rights in the software and documentation contained herein. +-- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making +-- this public release, the Government intends to confer upon all +-- recipients unlimited rights equal to those held by the Government. +-- These rights include rights to use, duplicate, release or disclose the +-- released technical data and computer software in whole or in part, in +-- any manner and for any purpose whatsoever, and to have or permit others +-- to do so. +-- +-- DISCLAIMER +-- +-- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR +-- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED +-- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF 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 'PRED' AND 'SUCC' YIELD THE CORRECT RESULT WHEN THE +-- PREFIX IS AN INTEGER TYPE. + +-- HISTORY: +-- RJW 03/17/86 CREATED ORIGINAL TEST. +-- DHH 10/19/87 SHORTENED LINES CONTAINING MORE THAN 72 CHARACTERS. + +WITH REPORT; USE REPORT; + +PROCEDURE C35503G IS + +BEGIN + TEST ("C35503G", "CHECK THAT 'PRED' AND 'SUCC' YIELD THE " & + "CORRECT RESULT WHEN THE PREFIX IS AN " & + "INTEGER TYPE" ); + + DECLARE + TYPE INT IS RANGE -6 .. 6; + SUBTYPE SINT IS INT RANGE -4 .. 4; + + BEGIN + + FOR I IN INT'FIRST + 1 .. INT'LAST LOOP + BEGIN + IF SINT'PRED (I) /= I - 1 THEN + FAILED ( "WRONG SINT'PRED FOR " & + INT'IMAGE (I)); + END IF; + EXCEPTION + WHEN OTHERS => + FAILED ( "EXCEPTION RAISED FOR " & + "SINT'PRED OF " & + INT'IMAGE (I)); + END; + END LOOP; + + FOR I IN INT'FIRST .. INT'LAST - 1 LOOP + BEGIN + IF SINT'SUCC (I) /= I + 1 THEN + FAILED ( "WRONG SINT'SUCC FOR " & + INT'IMAGE (I)); + END IF; + EXCEPTION + WHEN OTHERS => + FAILED ( "EXCEPTION RAISED FOR " & + "SINT'SUCC OF " & + INT'IMAGE (I)); + END; + END LOOP; + + END; + + DECLARE + SUBTYPE INTRANGE IS INTEGER RANGE IDENT_INT(-6) .. + IDENT_INT(6); + SUBTYPE SINTEGER IS INTEGER RANGE IDENT_INT(-4) .. + IDENT_INT(4); + + BEGIN + FOR I IN INTRANGE LOOP + BEGIN + IF SINTEGER'PRED (I) /= I - IDENT_INT(1) THEN + FAILED ( "WRONG SINTEGER'PRED FOR " & + INTEGER'IMAGE (I)); + END IF; + EXCEPTION + WHEN OTHERS => + FAILED ( "EXCEPTION RAISED FOR " & + "SINTEGER'PRED OF " & + INTEGER'IMAGE (I)); + END; + BEGIN + IF SINTEGER'SUCC (I) /= I + IDENT_INT(1) THEN + FAILED ( "WRONG SINTEGER'SUCC FOR " & + INTEGER'IMAGE (I)); + END IF; + EXCEPTION + WHEN OTHERS => + FAILED ( "EXCEPTION RAISED FOR " & + "SINTEGER'SUCC OF " & + INTEGER'IMAGE (I)); + END; + END LOOP; + + END; + + RESULT; +END C35503G; diff --git a/gcc-4.9/gcc/testsuite/ada/acats/tests/c3/c35503h.ada b/gcc-4.9/gcc/testsuite/ada/acats/tests/c3/c35503h.ada new file mode 100644 index 000000000..e1410673d --- /dev/null +++ b/gcc-4.9/gcc/testsuite/ada/acats/tests/c3/c35503h.ada @@ -0,0 +1,94 @@ +-- C35503H.ADA + +-- Grant of Unlimited Rights +-- +-- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687, +-- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained +-- unlimited rights in the software and documentation contained herein. +-- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making +-- this public release, the Government intends to confer upon all +-- recipients unlimited rights equal to those held by the Government. +-- These rights include rights to use, duplicate, release or disclose the +-- released technical data and computer software in whole or in part, in +-- any manner and for any purpose whatsoever, and to have or permit others +-- to do so. +-- +-- DISCLAIMER +-- +-- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR +-- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED +-- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF 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 'PRED' AND 'SUCC' YIELD THE CORRECT RESULT WHEN THE +-- PREFIX IS A GENERIC FORMAL DISCRETE TYPE WHOSE ACTUAL PARAMETER +-- IS AN INTEGER TYPE. + +-- HISTORY: +-- RJW 03/17/86 CREATED ORIGINAL TEST. +-- DHH 10/19/87 SHORTENED LINES CONTAINING MORE THAN 72 CHARACTERS. + +WITH REPORT; USE REPORT; + +PROCEDURE C35503H IS + +BEGIN + TEST ("C35503H", "CHECK THAT 'PRED' AND 'SUCC' YIELD THE " & + "CORRECT RESULT WHEN THE PREFIX IS A GENERIC " & + "FORMAL DISCRETE TYPE WHOSE ACTUAL PARAMETER " & + "IS AN INTEGER TYPE" ); + + DECLARE + TYPE INTRANGE IS RANGE -6 .. 6; + + GENERIC + TYPE INT IS (<>); + PROCEDURE P (STR : STRING); + + PROCEDURE P (STR : STRING) IS + SUBTYPE SINT IS INT + RANGE INT'VAL (IDENT_INT(-4)) .. + INT'VAL (IDENT_INT(4)); + BEGIN + FOR I IN INT'VAL (IDENT_INT(-6)) .. + INT'VAL (IDENT_INT(6)) + LOOP + BEGIN + IF SINT'PRED (I) /= + SINT'VAL (SINT'POS (I) - 1) THEN + FAILED ( "WRONG " & STR & "'PRED " & + "FOR " & INT'IMAGE (I) ); + END IF; + EXCEPTION + WHEN OTHERS => + FAILED ( "EXCEPTION RAISED FOR " & + STR & "'PRED OF " & + INT'IMAGE (I)); + END; + BEGIN + IF SINT'SUCC (I) /= + SINT'VAL (SINT'POS (I) + 1) THEN + FAILED ( "WRONG " & STR & "'SUCC " & + "FOR " & INT'IMAGE (I)); + END IF; + EXCEPTION + WHEN OTHERS => + FAILED ( "EXCEPTION RAISED FOR " & + STR & "'SUCC OF " & + INT'IMAGE (I)); + END; + END LOOP; + END P; + + PROCEDURE PROC1 IS NEW P (INTRANGE); + PROCEDURE PROC2 IS NEW P (INTEGER); + BEGIN + PROC1 ("INTRANGE"); + PROC2 ("INTEGER"); + END; + + RESULT; +END C35503H; diff --git a/gcc-4.9/gcc/testsuite/ada/acats/tests/c3/c35503k.ada b/gcc-4.9/gcc/testsuite/ada/acats/tests/c3/c35503k.ada new file mode 100644 index 000000000..e05021c6b --- /dev/null +++ b/gcc-4.9/gcc/testsuite/ada/acats/tests/c3/c35503k.ada @@ -0,0 +1,120 @@ +-- C35503K.ADA + +-- Grant of Unlimited Rights +-- +-- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687, +-- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained +-- unlimited rights in the software and documentation contained herein. +-- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making +-- this public release, the Government intends to confer upon all +-- recipients unlimited rights equal to those held by the Government. +-- These rights include rights to use, duplicate, release or disclose the +-- released technical data and computer software in whole or in part, in +-- any manner and for any purpose whatsoever, and to have or permit others +-- to do so. +-- +-- DISCLAIMER +-- +-- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR +-- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED +-- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF 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 'POS' AND 'VAL' YIELD THE CORRECT RESULTS WHEN THE +-- PREFIX IS AN INTEGER TYPE. + +-- HISTORY: +-- RJW 03/17/86 CREATED ORIGINAL TEST. +-- DHH 10/19/87 SHORTENED LINES CONTAINING MORE THAN 72 CHARACTERS. +-- PWN 11/30/94 REMOVED ATTRIBUTE TESTS ILLEGAL IN ADA 9X. + +WITH SYSTEM; USE SYSTEM; +WITH REPORT; USE REPORT; + +PROCEDURE C35503K IS + +BEGIN + TEST ("C35503K", "CHECK THAT 'POS' AND 'VAL' YIELD THE " & + "CORRECT RESULTS WHEN THE PREFIX IS AN " & + "INTEGER TYPE" ); + + DECLARE + TYPE INT IS RANGE -6 .. 6; + SUBTYPE SINT IS INT RANGE -4 .. 4; + + PROCEDURE P (I : INTEGER; STR : STRING) IS + BEGIN + BEGIN + IF INTEGER'POS (I) /= I THEN + FAILED ( "WRONG POS FOR " & STR); + END IF; + EXCEPTION + WHEN OTHERS => + FAILED ( "EXCEPTION RAISED FOR POS OF " & + STR); + END; + BEGIN + IF INTEGER'VAL (I) /= I THEN + FAILED ( "WRONG VAL FOR " & STR); + END IF; + EXCEPTION + WHEN OTHERS => + FAILED ( "EXCEPTION RAISED FOR VAL OF " & + STR); + END; + END P; + + BEGIN + P ( INTEGER'FIRST, "INTEGER'FIRST"); + P ( INTEGER'LAST, "INTEGER'LAST"); + P ( 0, "'0'"); + + FOR I IN INT'FIRST .. INT'LAST LOOP + BEGIN + IF SINT'POS (I) /= I THEN + FAILED ( "WRONG POS FOR " + & INT'IMAGE (I)); + END IF; + EXCEPTION + WHEN OTHERS => + FAILED ( "EXCEPTION RAISED FOR POS OF " + & INT'IMAGE (I)); + END; + BEGIN + IF SINT'VAL (I) /= I THEN + FAILED ( "WRONG VAL FOR " + & INT'IMAGE (I)); + END IF; + EXCEPTION + WHEN OTHERS => + FAILED ( "EXCEPTION RAISED FOR VAL OF " + & INT'IMAGE (I)); + END; + END LOOP; + + BEGIN + IF INT'VAL (INTEGER'(0)) /= 0 THEN + FAILED ( "WRONG VAL FOR INT WITH INTEGER" ); + END IF; + EXCEPTION + WHEN OTHERS => + FAILED ( "EXCEPTION RAISED FOR VAL OF " & + "INT WITH INTEGER" ); + END; + + BEGIN + IF INTEGER'VAL (INT'(0)) /= 0 THEN + FAILED ( "WRONG VAL FOR INTEGER WITH INT" ); + END IF; + EXCEPTION + WHEN OTHERS => + FAILED ( "EXCEPTION RAISED FOR VAL OF " & + "INTEGER WITH INT" ); + END; + END; + + RESULT; +END C35503K; diff --git a/gcc-4.9/gcc/testsuite/ada/acats/tests/c3/c35503l.ada b/gcc-4.9/gcc/testsuite/ada/acats/tests/c3/c35503l.ada new file mode 100644 index 000000000..33d571d9d --- /dev/null +++ b/gcc-4.9/gcc/testsuite/ada/acats/tests/c3/c35503l.ada @@ -0,0 +1,98 @@ +-- C35503L.ADA + +-- Grant of Unlimited Rights +-- +-- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687, +-- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained +-- unlimited rights in the software and documentation contained herein. +-- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making +-- this public release, the Government intends to confer upon all +-- recipients unlimited rights equal to those held by the Government. +-- These rights include rights to use, duplicate, release or disclose the +-- released technical data and computer software in whole or in part, in +-- any manner and for any purpose whatsoever, and to have or permit others +-- to do so. +-- +-- DISCLAIMER +-- +-- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR +-- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED +-- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF 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 'POS' AND 'VAL' YIELD THE CORRECT RESULTS WHEN THE +-- PREFIX IS A GENERIC FORMAL DISCRETE TYPE WHOSE ACTUAL PARAMETER +-- IS AN INTEGER TYPE. + +-- HISTORY: +-- RJW 03/17/86 CREATED ORIGINAL TEST. +-- DHH 10/19/87 SHORTENED LINES CONTAINING MORE THAN 72 CHARACTERS. + +WITH REPORT; USE REPORT; + +PROCEDURE C35503L IS + +BEGIN + TEST ("C35503L", "CHECK THAT 'POS' AND 'VAL' YIELD THE " & + "CORRECT RESULTS WHEN THE PREFIX IS A " & + "GENERIC FORMAL DISCRETE TYPE WHOSE " & + "ACTUAL PARAMETER IS AN INTEGER TYPE" ); + + DECLARE + TYPE INTRANGE IS RANGE -6 .. 6; + + GENERIC + TYPE INT IS (<>); + PROCEDURE P (STR : STRING); + + PROCEDURE P (STR : STRING) IS + SUBTYPE SINT IS INT RANGE + INT'VAL (IDENT_INT(-4)) .. INT'VAL (IDENT_INT(4)); + I :INTEGER; + BEGIN + I := IDENT_INT(-6); + FOR S IN INT'VAL (IDENT_INT(-6)) .. + INT'VAL (IDENT_INT(6)) + LOOP + BEGIN + IF SINT'POS (S) /= I THEN + FAILED ( "WRONG VALUE FOR " & + STR & "'POS OF " + & INT'IMAGE (S) ); + END IF; + EXCEPTION + WHEN OTHERS => + FAILED ( "EXCEPTION RAISED FOR " & + STR & "'POS " + & "OF " & INT'IMAGE (S) ); + END; + BEGIN + IF SINT'VAL (I) /= S THEN + FAILED ( "WRONG VALUE FOR " & + STR & "'VAL " + & "OF " & INT'IMAGE (S) ); + END IF; + EXCEPTION + WHEN OTHERS => + FAILED ( "EXCEPTION RAISED FOR " & + STR & "'VAL " + & "OF " & INT'IMAGE (S) ); + END; + I := I + 1; + END LOOP; + END P; + + PROCEDURE P1 IS NEW P (INTRANGE); + PROCEDURE P2 IS NEW P (INTEGER); + + BEGIN + P1 ("INTRANGE"); + P2 ("INTEGER"); + END; + + RESULT; + +END C35503L; diff --git a/gcc-4.9/gcc/testsuite/ada/acats/tests/c3/c35503o.ada b/gcc-4.9/gcc/testsuite/ada/acats/tests/c3/c35503o.ada new file mode 100644 index 000000000..57d288f37 --- /dev/null +++ b/gcc-4.9/gcc/testsuite/ada/acats/tests/c3/c35503o.ada @@ -0,0 +1,125 @@ +-- C35503O.ADA + +-- Grant of Unlimited Rights +-- +-- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687, +-- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained +-- unlimited rights in the software and documentation contained herein. +-- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making +-- this public release, the Government intends to confer upon all +-- recipients unlimited rights equal to those held by the Government. +-- These rights include rights to use, duplicate, release or disclose the +-- released technical data and computer software in whole or in part, in +-- any manner and for any purpose whatsoever, and to have or permit others +-- to do so. +-- +-- DISCLAIMER +-- +-- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR +-- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED +-- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF 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 'FIRST' AND 'LAST' YIELD THE CORRECT RESULTS WHEN THE +-- PREFIX IS AN INTEGER TYPE. + +-- HISTORY: +-- RJW 03/17/86 CREATED ORIGINAL TEST. +-- DHH 10/19/87 SHORTENED LINES CONTAINING MORE THAN 72 CHARACTERS. + +WITH REPORT; USE REPORT; + +PROCEDURE C35503O IS + +BEGIN + TEST ("C35503O", "CHECK THAT 'FIRST' AND 'LAST' YIELD THE " & + "CORRECT RESULTS WHEN THE PREFIX IS AN " & + "INTEGER TYPE" ); + + DECLARE + SUBTYPE SINTEGER IS INTEGER; + SUBTYPE SMALL IS INTEGER RANGE IDENT_INT(-10) .. + IDENT_INT(10); + SUBTYPE NOINTEGER IS INTEGER + RANGE IDENT_INT(5) .. IDENT_INT(-7); + + TYPE INT IS RANGE -6 .. 6; + SUBTYPE SINT IS INT + RANGE INT(IDENT_INT(-4)) .. INT(IDENT_INT(4)); + SUBTYPE NOINT IS INT + RANGE INT(IDENT_INT(1)) .. INT(IDENT_INT(-1)); + TYPE NEWINT IS NEW INTEGER RANGE IDENT_INT(-9) .. + IDENT_INT(-2); + SUBTYPE SNEWINT IS NEWINT RANGE -7 .. -5; + SUBTYPE NONEWINT IS NEWINT RANGE 3 .. -15; + + BEGIN + IF SINTEGER'FIRST /= INTEGER'FIRST THEN + FAILED ( "WRONG VALUE FOR SINTEGER'FIRST" ); + END IF; + IF SINTEGER'LAST /= INTEGER'LAST THEN + FAILED ( "WRONG VALUE FOR SINTEGER'LAST" ); + END IF; + + IF SMALL'FIRST /= -10 THEN + FAILED ( "WRONG VALUE FOR SMALL'FIRST" ); + END IF; + IF SMALL'LAST /= 10 THEN + FAILED ( "WRONG VALUE FOR SMALL'LAST" ); + END IF; + + IF NOINTEGER'FIRST /= 5 THEN + FAILED ( "WRONG VALUE FOR NOINTEGER'FIRST" ); + END IF; + IF NOINTEGER'LAST /= -7 THEN + FAILED ( "WRONG VALUE FOR NOINTEGER'LAST" ); + END IF; + + IF INT'FIRST /= -6 THEN + FAILED ( "WRONG VALUE FOR INT'FIRST" ); + END IF; + IF INT'LAST /= 6 THEN + FAILED ( "WRONG VALUE FOR INT'LAST" ); + END IF; + + IF SINT'FIRST /= -4 THEN + FAILED ( "WRONG VALUE FOR SINT'FIRST" ); + END IF; + IF SINT'LAST /= 4 THEN + FAILED ( "WRONG VALUE FOR SINT'LAST" ); + END IF; + + IF NOINT'FIRST /= 1 THEN + FAILED ( "WRONG VALUE FOR NOINT'FIRST" ); + END IF; + IF NOINT'LAST /= -1 THEN + FAILED ( "WRONG VALUE FOR NOINT'LAST" ); + END IF; + + IF NEWINT'FIRST /= -9 THEN + FAILED ( "WRONG VALUE FOR NEWINT'FIRST" ); + END IF; + IF NEWINT'LAST /= -2 THEN + FAILED ( "WRONG VALUE FOR NEWINT'LAST" ); + END IF; + + IF SNEWINT'FIRST /= -7 THEN + FAILED ( "WRONG VALUE FOR SNEWINT'FIRST" ); + END IF; + IF SNEWINT'LAST /= -5 THEN + FAILED ( "WRONG VALUE FOR SNEWINT'LAST" ); + END IF; + + IF NONEWINT'FIRST /= 3 THEN + FAILED ( "WRONG VALUE FOR NONEWINT'FIRST" ); + END IF; + IF NONEWINT'LAST /= -15 THEN + FAILED ( "WRONG VALUE FOR NONEWINT'LAST" ); + END IF; + END; + + RESULT; +END C35503O; diff --git a/gcc-4.9/gcc/testsuite/ada/acats/tests/c3/c35503p.ada b/gcc-4.9/gcc/testsuite/ada/acats/tests/c3/c35503p.ada new file mode 100644 index 000000000..28ecac33b --- /dev/null +++ b/gcc-4.9/gcc/testsuite/ada/acats/tests/c3/c35503p.ada @@ -0,0 +1,113 @@ +-- C35503P.ADA + +-- Grant of Unlimited Rights +-- +-- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687, +-- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained +-- unlimited rights in the software and documentation contained herein. +-- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making +-- this public release, the Government intends to confer upon all +-- recipients unlimited rights equal to those held by the Government. +-- These rights include rights to use, duplicate, release or disclose the +-- released technical data and computer software in whole or in part, in +-- any manner and for any purpose whatsoever, and to have or permit others +-- to do so. +-- +-- DISCLAIMER +-- +-- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR +-- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED +-- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF 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 'FIRST' AND 'LAST' YIELD THE CORRECT RESULTS WHEN THE +-- PREFIX IS A GENERIC FORMAL DISCRETE TYPE WHOSE ARGUMENT IS AN +-- INTEGER TYPE. + +-- HISTORY: +-- RJW 03/24/86 CREATED ORIGINAL TEST. +-- DHH 10/19/87 SHORTENED LINES CONTAINING MORE THAN 72 CHARACTERS. + +WITH REPORT; USE REPORT; + +PROCEDURE C35503P IS + +BEGIN + TEST ("C35503P", "CHECK THAT 'FIRST' AND 'LAST' YIELD THE " & + "CORRECT RESULTS WHEN THE PREFIX IS A " & + "GENERIC FORMAL DISCRETE TYPE WHOSE ARGUMENT " & + "IS AN INTEGER TYPE" ); + + + DECLARE + + TYPE INT IS RANGE -6 .. 6; + SUBTYPE SINT IS INT RANGE INT(IDENT_INT(-4)) .. + INT(IDENT_INT(4)); + SUBTYPE NOINT IS INT RANGE INT(IDENT_INT(1)) .. + INT(IDENT_INT(-1)); + + GENERIC + TYPE I IS (<>); + F, L : I; + PROCEDURE P ( STR : STRING ); + + PROCEDURE P ( STR : STRING ) IS + BEGIN + IF I'FIRST /= F THEN + FAILED ( "INCORRECT 'FIRST' FOR " & STR ); + END IF; + IF I'LAST /= L THEN + FAILED ( "INCORRECT 'LAST' FOR " & STR ); + END IF; + END P; + + GENERIC + TYPE I IS (<>); + F, L : I; + PROCEDURE Q; + + PROCEDURE Q IS + SUBTYPE SI IS I; + BEGIN + IF SI'FIRST /= F THEN + FAILED ( "INCORRECT VALUE FOR INTEGER'FIRST" ); + END IF; + IF SI'LAST /= L THEN + FAILED ( "INCORRECT VALUE FOR INTEGER'LAST" ); + END IF; + END Q; + + GENERIC + TYPE I IS (<>); + PROCEDURE R; + + PROCEDURE R IS + SUBTYPE SI IS I; + BEGIN + IF SI'FIRST /= SI'VAL (IDENT_INT(1)) THEN + FAILED ( "INCORRECT VALUE FOR NOINT'FIRST" ); + END IF; + IF SI'LAST /= SI'VAL (IDENT_INT(-1)) THEN + FAILED ( "INCORRECT VALUE FOR NOINT'LAST" ); + END IF; + END R; + + PROCEDURE P1 IS NEW P ( I => INT, F => -6, L => 6 ); + PROCEDURE P2 IS NEW P ( I => SINT, F => -4, L => 4 ); + PROCEDURE Q1 IS NEW Q + ( I => INTEGER, F => INTEGER'FIRST, L => INTEGER'LAST ); + PROCEDURE R1 IS NEW R ( I => NOINT); + + BEGIN + P1 ( "INT" ); + P2 ( "SINT" ); + Q1; + R1; + END; + + RESULT; +END C35503P; diff --git a/gcc-4.9/gcc/testsuite/ada/acats/tests/c3/c35504a.ada b/gcc-4.9/gcc/testsuite/ada/acats/tests/c3/c35504a.ada new file mode 100644 index 000000000..6c2c59a1d --- /dev/null +++ b/gcc-4.9/gcc/testsuite/ada/acats/tests/c3/c35504a.ada @@ -0,0 +1,63 @@ +-- C35504A.ADA + +-- Grant of Unlimited Rights +-- +-- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687, +-- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained +-- unlimited rights in the software and documentation contained herein. +-- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making +-- this public release, the Government intends to confer upon all +-- recipients unlimited rights equal to those held by the Government. +-- These rights include rights to use, duplicate, release or disclose the +-- released technical data and computer software in whole or in part, in +-- any manner and for any purpose whatsoever, and to have or permit others +-- to do so. +-- +-- DISCLAIMER +-- +-- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR +-- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED +-- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE +-- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE +-- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A +-- PARTICULAR PURPOSE OF SAID MATERIAL. +--* +-- CHECK THAT CONSTRAINT_ERROR IS NOT RAISED WHEN THE USER-DEFINED +-- ENUMERATION ARGUMENT TO 'SUCC, 'PRED, 'POS, 'VAL, 'IMAGE, AND 'VALUE +-- IS NOT IN THE ATTRIBUTED SUBTYPE'S RANGE CONSTRAINT. + +-- DAT 3/18/81 +-- SPS 01/13/83 + +WITH REPORT; USE REPORT; + +PROCEDURE C35504A IS + + TYPE E IS (A, 'A', B, 'B', C, 'C', D, 'D', XYZ); + + SUBTYPE S IS E RANGE B .. C; + +BEGIN + TEST ("C35504A", "CONSTRAINT_ERROR IS NOT RAISED IN T'SUCC(X)," + & " T'PRED(X), T'POS(X), T'VAL(X), T'IMAGE(X), AND" + & " T'VALUE(X) WHEN THE VALUES ARE NOT WITHIN T'S" + & " RANGE CONSTRAINT, FOR USER-DEFINED ENUMERATION TYPES"); + + BEGIN + FOR X IN E LOOP + IF (X /= A AND THEN S'SUCC(S'PRED(X)) /= X) + OR (X /= XYZ AND THEN S'PRED(S'SUCC(X)) /= X) + OR S'VAL(S'POS(X)) /= X + OR S'VALUE(S'IMAGE(X)) /= X + THEN + FAILED ("WRONG ATTRIBUTE VALUE"); + END IF; + END LOOP; + EXCEPTION + WHEN CONSTRAINT_ERROR => FAILED ("CONSTRAINT_ERROR RAISED" + & " WHEN IT SHOULDN'T HAVE BEEN"); + WHEN OTHERS => FAILED ("INCORRECT EXCEPTION RAISED"); + END; + + RESULT; +END C35504A; diff --git a/gcc-4.9/gcc/testsuite/ada/acats/tests/c3/c35504b.ada b/gcc-4.9/gcc/testsuite/ada/acats/tests/c3/c35504b.ada new file mode 100644 index 000000000..644b1d643 --- /dev/null +++ b/gcc-4.9/gcc/testsuite/ada/acats/tests/c3/c35504b.ada @@ -0,0 +1,85 @@ +-- C35504B.ADA + +-- Grant of Unlimited Rights +-- +-- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687, +-- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained +-- unlimited rights in the software and documentation contained herein. +-- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making +-- this public release, the Government intends to confer upon all +-- recipients unlimited rights equal to those held by the Government. +-- These rights include rights to use, duplicate, release or disclose the +-- released technical data and computer software in whole or in part, in +-- any manner and for any purpose whatsoever, and to have or permit others +-- to do so. +-- +-- DISCLAIMER +-- +-- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR +-- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED +-- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE +-- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE +-- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A +-- PARTICULAR PURPOSE OF SAID MATERIAL. +--* +-- CHECK THAT CONSTRAINT_ERROR IS NOT RAISED FOR I'SUCC, I'PRED, +-- I'POS, I'VAL, I'IMAGE, AND I'VALUE FOR INTEGER ARGUMENTS +-- OUTSIDE THE RANGE OF I. + +-- DAT 3/30/81 +-- SPS 01/13/83 + +WITH REPORT; +USE REPORT; + +PROCEDURE C35504B IS + + SUBTYPE I IS INTEGER RANGE 0 .. 0; + +BEGIN + TEST ("C35504B", "CONSTRAINT_ERROR IS NOT RAISED FOR" + & " INTEGER SUBTYPE ATTRIBUTES 'SUCC, 'PRED, 'POS, 'VAL," + & " 'IMAGE, AND 'VALUE WHOSE ARGUMENTS ARE OUTSIDE THE" + & " SUBTYPE"); + + BEGIN + IF I'SUCC(-1) /= I'PRED(1) + THEN + FAILED ("WRONG ATTRIBUTE VALUE - 1"); + END IF; + + IF I'SUCC (100) /= 101 + THEN + FAILED ("WRONG ATTRIBUTE VALUE - 2"); + END IF; + + IF I'PRED (100) /= 99 + THEN + FAILED ("WRONG ATTRIBUTE VALUE - 3"); + END IF; + + IF I'POS (-100) /= -100 + THEN + FAILED ("WRONG ATTRIBUTE VALUE - 4"); + END IF; + + IF I'VAL(-100) /= -100 + THEN + FAILED ("WRONG ATTRIBUTE VALUE - 5"); + END IF; + + IF I'IMAGE(1234) /= " 1234" + THEN + FAILED ("WRONG ATTRIBUTE VALUE - 6"); + END IF; + + IF I'VALUE("999") /= 999 + THEN + FAILED ("WRONG ATTRIBUTE VALUE - 7"); + END IF; + EXCEPTION + WHEN OTHERS => FAILED ("EXCEPTION RAISED"); + END; + + RESULT; +END C35504B; diff --git a/gcc-4.9/gcc/testsuite/ada/acats/tests/c3/c35505c.ada b/gcc-4.9/gcc/testsuite/ada/acats/tests/c3/c35505c.ada new file mode 100644 index 000000000..52bf7f211 --- /dev/null +++ b/gcc-4.9/gcc/testsuite/ada/acats/tests/c3/c35505c.ada @@ -0,0 +1,102 @@ +-- C35505C.ADA + +-- Grant of Unlimited Rights +-- +-- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687, +-- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained +-- unlimited rights in the software and documentation contained herein. +-- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making +-- this public release, the Government intends to confer upon all +-- recipients unlimited rights equal to those held by the Government. +-- These rights include rights to use, duplicate, release or disclose the +-- released technical data and computer software in whole or in part, in +-- any manner and for any purpose whatsoever, and to have or permit others +-- to do so. +-- +-- DISCLAIMER +-- +-- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR +-- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED +-- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE +-- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE +-- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A +-- PARTICULAR PURPOSE OF SAID MATERIAL. +--* +-- OBJECTIVE: +-- CHECK THAT CONSTRAINT_ERROR IS RAISED FOR 'SUCC' AND 'PRED', +-- IF THE RETURNED VALUES WOULD BE OUTSIDE OF THE BASE TYPE, +-- WHEN THE PREFIX IS A FORMAL DISCRETE TYPE WHOSE ACTUAL ARGUMENT +-- IS A USER-DEFINED ENUMERATION TYPE. + +-- HISTORY: +-- RJW 06/05/86 CREATED ORIGINAL TEST. +-- VCL 08/19/87 REMOVED THE FUNCTION 'IDENT' IN THE GENERIC +-- PROCEDURE 'P' AND REPLACED ALL CALLS TO 'IDENT' +-- WITH "T'VAL(IDENT_INT(T'POS(...)))". + +WITH REPORT; USE REPORT; + +PROCEDURE C35505C IS + + TYPE B IS ('Z', 'X', Z, X); + + SUBTYPE C IS B RANGE 'X' .. Z; + +BEGIN + TEST ( "C35505C", "CHECK THAT 'SUCC' AND 'PRED' RAISE " & + "CONSTRAINT_ERROR APPROPRIATELY WHEN THE " & + "PREFIX IS A FORMAL DISCRETE TYPE WHOSE " & + "ARGUMENT IS A USER-DEFINED ENUMERATION TYPE" ); + + DECLARE + GENERIC + TYPE T IS (<>); + STR : STRING; + PROCEDURE P; + + PROCEDURE P IS + + BEGIN + BEGIN + IF T'PRED (T'VAL (IDENT_INT (T'POS + (T'BASE'FIRST)))) = T'FIRST THEN + FAILED ( "CONSTRAINT_ERROR NOT RAISED FOR " & + STR & "'PRED - 1" ); + ELSE + FAILED ( "CONSTRAINT_ERROR NOT RAISED FOR " & + STR & "'PRED - 2" ); + END IF; + EXCEPTION + WHEN CONSTRAINT_ERROR => + NULL; + WHEN OTHERS => + FAILED ( "WRONG EXCEPTION RAISED FOR " & + STR & "'PRED - 1" ); + END; + + BEGIN + IF T'SUCC (T'VAL (IDENT_INT (T'POS + (T'BASE'LAST)))) = T'LAST THEN + FAILED ( "CONSTRAINT_ERROR NOT RAISED FOR " & + STR & "'SUCC - 1" ); + ELSE + FAILED ( "CONSTRAINT_ERROR NOT RAISED FOR " & + STR & "'SUCC - 2" ); + END IF; + EXCEPTION + WHEN CONSTRAINT_ERROR => + NULL; + WHEN OTHERS => + FAILED ( "WRONG EXCEPTION RAISED FOR " & + STR & "'SUCC - 1" ); + END; + END P; + + PROCEDURE PB IS NEW P (B, "B"); + PROCEDURE PC IS NEW P (C, "C"); + BEGIN + PB; + PC; + END; +RESULT; +END C35505C; diff --git a/gcc-4.9/gcc/testsuite/ada/acats/tests/c3/c35505e.ada b/gcc-4.9/gcc/testsuite/ada/acats/tests/c3/c35505e.ada new file mode 100644 index 000000000..0da82dae9 --- /dev/null +++ b/gcc-4.9/gcc/testsuite/ada/acats/tests/c3/c35505e.ada @@ -0,0 +1,144 @@ +-- C35505E.ADA + +-- Grant of Unlimited Rights +-- +-- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687, +-- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained +-- unlimited rights in the software and documentation contained herein. +-- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making +-- this public release, the Government intends to confer upon all +-- recipients unlimited rights equal to those held by the Government. +-- These rights include rights to use, duplicate, release or disclose the +-- released technical data and computer software in whole or in part, in +-- any manner and for any purpose whatsoever, and to have or permit others +-- to do so. +-- +-- DISCLAIMER +-- +-- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR +-- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED +-- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE +-- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE +-- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A +-- PARTICULAR PURPOSE OF SAID MATERIAL. +--* +-- OBJECTIVE: +-- CHECK THAT CONSTRAINT_ERROR IS RAISED FOR 'SUCC' AND 'PRED', +-- IF THE RESULT WOULD BE OUTSIDE THE RANGE OF THE BASE TYPE, +-- WHEN THE PREFIX IS A FORMAL DISCRETE TYPE WHOSE ACTUAL ARGUMENT +-- IS TYPE CHARACTER OR A SUBTYPE OF TYPE CHARACTER. + +-- HISTORY: +-- DWC 07/01/87 + +WITH REPORT; USE REPORT; + +PROCEDURE C35505E IS + + TYPE CHAR IS ('A', B, C); + SUBTYPE NEWCHAR IS CHAR; + +BEGIN + TEST ( "C35505E", "CHECK THAT CONSTRAINT_ERROR IS RAISED FOR " & + "'SUCC' AND 'PRED', IF THE RESULT WOULD BE " & + "OUTSIDE THE RANGE OF THE BASE TYPE, WHEN " & + "THE PREFIX IS A FORMAL DISCRETE TYPE WHOSE " & + "ACTUAL ARGUMENT IS A CHARACTER TYPE "); + + DECLARE + GENERIC + TYPE SUBCH IS (<>); + STR : STRING; + I1, I2 : INTEGER; + PROCEDURE P; + + PROCEDURE P IS + + FUNCTION IDENT (C : SUBCH) RETURN SUBCH IS + BEGIN + RETURN SUBCH'VAL (IDENT_INT (SUBCH'POS (C))); + END IDENT; + + BEGIN + BEGIN + IF SUBCH'PRED (SUBCH'BASE'FIRST) = SUBCH'VAL (0) + THEN + FAILED ( "CONSTRAINT_ERROR NOT RAISED FOR " & + STR & "'PRED - 1" ); + ELSE + FAILED ( "CONSTRAINT_ERROR NOT RAISED FOR " & + STR & "'PRED - 2" ); + END IF; + EXCEPTION + WHEN CONSTRAINT_ERROR => + NULL; + WHEN OTHERS => + FAILED ( "WRONG EXCEPTION RAISED FOR " & + STR & "'PRED - 1" ); + END; + + BEGIN + IF SUBCH'SUCC (SUBCH'BASE'LAST) = SUBCH'VAL (0) THEN + FAILED ( "CONSTRAINT_ERROR NOT RAISED FOR " & + STR & "'SUCC - 1" ); + ELSE + FAILED ( "CONSTRAINT_ERROR NOT RAISED FOR " & + STR & "'SUCC - 2" ); + END IF; + EXCEPTION + WHEN CONSTRAINT_ERROR => + NULL; + WHEN OTHERS => + FAILED ( "WRONG EXCEPTION RAISED FOR " & + STR & "'SUCC - 1" ); + END; + + BEGIN + IF SUBCH'PRED (IDENT (SUBCH'BASE'FIRST)) = + SUBCH'VAL (I1) THEN + FAILED ( "NO EXCEPTION RAISED " & + "FOR " & STR & "'PRED " & + "(IDENT (SUBCH'BASE'FIRST)) - 1" ); + ELSE + FAILED ( "NO EXCEPTION RAISED " & + "FOR " & STR & "'PRED " & + "(IDENT (SUBCH'BASE'FIRST)) - 2" ); + END IF; + EXCEPTION + WHEN CONSTRAINT_ERROR => + NULL; + WHEN OTHERS => + FAILED ( "WRONG EXCEPTION RAISED " & + "FOR " & STR & "'PRED " & + "(IDENT (SUBCH'BASE'FIRST))" ); + END; + + BEGIN + IF SUBCH'SUCC (IDENT(SUBCH'BASE'LAST)) = + SUBCH'VAL (I2) THEN + FAILED ( "NO EXCEPTION RAISED " & + "FOR " & STR & "'SUCC " & + "(IDENT (SUBCH'BASE'LAST)) - 1" ); + ELSE + FAILED ( "NO EXCEPTION RAISED " & + "FOR " & STR & "'SUCC " & + "(IDENT (SUBCH'BASE'LAST)) - 2" ); + END IF; + EXCEPTION + WHEN CONSTRAINT_ERROR => + NULL; + WHEN OTHERS => + FAILED ( "WRONG EXCEPTION RAISED " & + "FOR " & STR & "'SUCC " & + "(IDENT (SUBCH'BASE'LAST))" ); + END; + END P; + + PROCEDURE PCHAR IS NEW P (CHAR, "CHAR", 0, 1); + PROCEDURE PNCHAR IS NEW P (NEWCHAR, "NEWCHAR", 0, 1); + BEGIN + PCHAR; + PNCHAR; + END; +RESULT; +END C35505E; diff --git a/gcc-4.9/gcc/testsuite/ada/acats/tests/c3/c35505f.ada b/gcc-4.9/gcc/testsuite/ada/acats/tests/c3/c35505f.ada new file mode 100644 index 000000000..b8d4acc1b --- /dev/null +++ b/gcc-4.9/gcc/testsuite/ada/acats/tests/c3/c35505f.ada @@ -0,0 +1,164 @@ +-- C35505F.ADA + +-- Grant of Unlimited Rights +-- +-- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687, +-- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained +-- unlimited rights in the software and documentation contained herein. +-- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making +-- this public release, the Government intends to confer upon all +-- recipients unlimited rights equal to those held by the Government. +-- These rights include rights to use, duplicate, release or disclose the +-- released technical data and computer software in whole or in part, in +-- any manner and for any purpose whatsoever, and to have or permit others +-- to do so. +-- +-- DISCLAIMER +-- +-- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR +-- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED +-- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE +-- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE +-- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A +-- PARTICULAR PURPOSE OF SAID MATERIAL. +--* +-- OBJECTIVE: +-- CHECK THAT CONSTRAINT ERROR IS RAISED BY THE ATTRIBUTES +-- 'PRED' AND 'SUCC' WHEN THE PREFIX IS A CHARACTER TYPE +-- AND THE RESULT IS OUTSIDE OF THE BASE TYPE. + +-- HISTORY: +-- JET 08/18/87 CREATED ORIGINAL TEST. + +WITH REPORT; USE REPORT; + +PROCEDURE C35505F IS + + TYPE CHAR IS ('A', B); + + TYPE NEWCHAR IS NEW CHAR; + + FUNCTION IDENT (CH : CHAR) RETURN CHAR IS + BEGIN + RETURN CHAR'VAL (IDENT_INT (CHAR'POS (CH))); + END; + + FUNCTION IDENT (CH : NEWCHAR) RETURN NEWCHAR IS + BEGIN + RETURN NEWCHAR'VAL (IDENT_INT (NEWCHAR'POS (CH))); + END; + +BEGIN + + TEST( "C35505F" , "CHECK THAT CONSTRAINT ERROR IS RAISED BY " & + "THE ATTRIBUTES 'PRED' AND 'SUCC' WHEN THE " & + "PREFIX IS A CHARACTER TYPE AND THE RESULT " & + "IS OUTSIDE OF THE BASE TYPE" ); + + BEGIN + IF CHAR'PRED (IDENT ('A')) = 'A' THEN + FAILED ( "NO EXCEPTION RAISED " & + "FOR CHAR'PRED (IDENT ('A')) - 1" ); + ELSE + FAILED ( "NO EXCEPTION RAISED " & + "FOR CHAR'PRED (IDENT ('A')) - 2" ); + END IF; + EXCEPTION + WHEN CONSTRAINT_ERROR => + NULL; + WHEN OTHERS => + FAILED ( "WRONG EXCEPTION RAISED " & + "FOR CHAR'PRED (IDENT ('A'))" ); + END; + + BEGIN + IF CHAR'SUCC (IDENT (B)) = B THEN + FAILED ( "NO EXCEPTION RAISED " & + "FOR CHAR'SUCC (IDENT (B)) - 1" ); + ELSE + FAILED ( "NO EXCEPTION RAISED " & + "FOR CHAR'SUCC (IDENT (B)) - 2" ); + END IF; + EXCEPTION + WHEN CONSTRAINT_ERROR => + NULL; + WHEN OTHERS => + FAILED ( "WRONG EXCEPTION RAISED " & + "FOR CHAR'SUCC (IDENT (B))" ); + END; + + BEGIN + IF NEWCHAR'PRED (IDENT ('A')) = 'A' THEN + FAILED ( "NO EXCEPTION RAISED " & + "FOR NEWCHAR'PRED (IDENT ('A')) - 1" ); + ELSE + FAILED ( "NO EXCEPTION RAISED " & + "FOR NEWCHAR'PRED (IDENT ('A')) - 2" ); + END IF; + EXCEPTION + WHEN CONSTRAINT_ERROR => + NULL; + WHEN OTHERS => + FAILED ( "WRONG EXCEPTION RAISED " & + "FOR NEWCHAR'PRED (IDENT ('A'))" ); + END; + + BEGIN + IF NEWCHAR'SUCC (IDENT (B)) = 'A' THEN + FAILED ( "NO EXCEPTION RAISED " & + "FOR NEWCHAR'SUCC (IDENT (B)) - 1" ); + ELSE + FAILED ( "NO EXCEPTION RAISED " & + "FOR NEWCHAR'SUCC (IDENT (B)) - 2" ); + END IF; + EXCEPTION + WHEN CONSTRAINT_ERROR => + NULL; + WHEN OTHERS => + FAILED ( "WRONG EXCEPTION RAISED " & + "FOR NEWCHAR'SUCC (IDENT (B))" ); + END; + + BEGIN + IF CHARACTER'PRED (IDENT_CHAR (CHARACTER'BASE'FIRST)) = 'A' + THEN + FAILED ( "NO EXCEPTION RAISED " & + "FOR CHARACTER'PRED " & + "(IDENT_CHAR (CHARACTER'BASE'FIRST)) - 1" ); + ELSE + FAILED ( "NO EXCEPTION RAISED " & + "FOR CHARACTER'PRED " & + "(IDENT_CHAR (CHARACTER'BASE'FIRST)) - 2" ); + END IF; + EXCEPTION + WHEN CONSTRAINT_ERROR => + NULL; + WHEN OTHERS => + FAILED ( "WRONG EXCEPTION RAISED " & + "FOR CHARACTER'PRED " & + "(IDENT_CHAR (CHARACTER'BASE'FIRST))" ); + END; + + BEGIN + IF CHARACTER'SUCC (IDENT_CHAR (CHARACTER'BASE'LAST)) = 'Z' + THEN + FAILED ( "NO EXCEPTION RAISED " & + "FOR CHARACTER'SUCC " & + "(IDENT_CHAR (CHARACTER'BASE'LAST)) - 1" ); + ELSE + FAILED ( "NO EXCEPTION RAISED " & + "FOR CHARACTER'SUCC " & + "(IDENT_CHAR (CHARACTER'BASE'LAST)) - 2" ); + END IF; + EXCEPTION + WHEN CONSTRAINT_ERROR => + NULL; + WHEN OTHERS => + FAILED ( "WRONG EXCEPTION RAISED " & + "FOR CHARACTER'SUCC " & + "(IDENT_CHAR (CHARACTER'BASE'LAST))" ); + END; + + RESULT; + +END C35505F; diff --git a/gcc-4.9/gcc/testsuite/ada/acats/tests/c3/c35507a.ada b/gcc-4.9/gcc/testsuite/ada/acats/tests/c3/c35507a.ada new file mode 100644 index 000000000..0a6776560 --- /dev/null +++ b/gcc-4.9/gcc/testsuite/ada/acats/tests/c3/c35507a.ada @@ -0,0 +1,88 @@ +-- C35507A.ADA + +-- Grant of Unlimited Rights +-- +-- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687, +-- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained +-- unlimited rights in the software and documentation contained herein. +-- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making +-- this public release, the Government intends to confer upon all +-- recipients unlimited rights equal to those held by the Government. +-- These rights include rights to use, duplicate, release or disclose the +-- released technical data and computer software in whole or in part, in +-- any manner and for any purpose whatsoever, and to have or permit others +-- to do so. +-- +-- DISCLAIMER +-- +-- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR +-- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED +-- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF 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 ATTRIBUTE 'WIDTH' YIELDS THE CORRECT RESULTS +-- WHEN THE PREFIX IS A CHARACTER TYPE. + +-- RJW 5/29/86 + +WITH REPORT; USE REPORT; + +PROCEDURE C35507A IS + +BEGIN + + TEST( "C35507A" , "CHECK THAT THE ATTRIBUTE 'WIDTH' YIELDS " & + "THE CORRECT RESULTS WHEN THE PREFIX " & + "IS A CHARACTER TYPE" ); + + DECLARE + TYPE CHAR1 IS (A, 'A'); + + SUBTYPE CHAR2 IS CHARACTER RANGE 'A' .. 'Z'; + + SUBTYPE NOCHAR IS CHARACTER RANGE 'Z' .. 'A'; + + TYPE NEWCHAR IS NEW CHARACTER + RANGE 'A' .. 'Z'; + + BEGIN + IF CHAR1'WIDTH /= 3 THEN + FAILED( "INCORRECT WIDTH FOR CHAR1" ); + END IF; + + IF CHAR2'WIDTH /= 3 THEN + FAILED( "INCORRECT WIDTH FOR CHAR2" ); + END IF; + + IF NEWCHAR'WIDTH /= 3 THEN + FAILED( "INCORRECT WIDTH FOR NEWCHAR" ); + END IF; + + IF NOCHAR'WIDTH /= 0 THEN + FAILED( "INCORRECT WIDTH FOR NOCHAR" ); + END IF; + END; + + DECLARE + SUBTYPE NONGRAPH IS CHARACTER + RANGE CHARACTER'VAL (0) .. CHARACTER'VAL (31); + + MAX : INTEGER := 0; + + BEGIN + FOR CH IN NONGRAPH + LOOP + IF CHARACTER'IMAGE (CH)'LENGTH > MAX THEN + MAX := CHARACTER'IMAGE (CH)'LENGTH; + END IF; + END LOOP; + + IF NONGRAPH'WIDTH /= MAX THEN + FAILED ( "INCORRECT WIDTH FOR NONGRAPH" ); + END IF; + END; + + RESULT; +END C35507A; diff --git a/gcc-4.9/gcc/testsuite/ada/acats/tests/c3/c35507b.ada b/gcc-4.9/gcc/testsuite/ada/acats/tests/c3/c35507b.ada new file mode 100644 index 000000000..b50c4c0dc --- /dev/null +++ b/gcc-4.9/gcc/testsuite/ada/acats/tests/c3/c35507b.ada @@ -0,0 +1,96 @@ +-- C35507B.ADA + +-- Grant of Unlimited Rights +-- +-- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687, +-- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained +-- unlimited rights in the software and documentation contained herein. +-- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making +-- this public release, the Government intends to confer upon all +-- recipients unlimited rights equal to those held by the Government. +-- These rights include rights to use, duplicate, release or disclose the +-- released technical data and computer software in whole or in part, in +-- any manner and for any purpose whatsoever, and to have or permit others +-- to do so. +-- +-- DISCLAIMER +-- +-- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR +-- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED +-- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF 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 ATTRIBUTE 'WIDTH' YIELDS THE CORRECT RESULTS +-- WHEN THE PREFIX IS FORMAL DISCRETE TYPE WHOSE ACTUAL PARAMETER IS +-- A CHARACTER TYPE. + +-- RJW 5/29/86 + +WITH REPORT; USE REPORT; + +PROCEDURE C35507B IS + + GENERIC + TYPE CH IS (<>); + PROCEDURE P ( STR : STRING; W : INTEGER ); + + PROCEDURE P ( STR : STRING; W : INTEGER ) IS + + SUBTYPE NOCHAR IS CH RANGE CH'VAL (1) .. CH'VAL(0); + BEGIN + IF CH'WIDTH /= W THEN + FAILED( "INCORRECT WIDTH FOR " & STR ); + END IF; + + IF NOCHAR'WIDTH /= 0 THEN + FAILED( "INCORRECT WIDTH FOR NOCHAR WITH " & STR ); + END IF; + END P; + + +BEGIN + + TEST( "C35507B" , "CHECK THAT THE ATTRIBUTE 'WIDTH' YIELDS " & + "THE CORRECT RESULTS WHEN THE PREFIX " & + "IS A FORMAL DISCRETE TYPE WHOSE ACTUAL " & + "PARAMETER IS A CHARACTER TYPE" ); + + DECLARE + TYPE CHAR1 IS (A, 'A'); + + SUBTYPE CHAR2 IS CHARACTER RANGE 'A' .. 'Z'; + + TYPE NEWCHAR IS NEW CHARACTER + RANGE 'A' .. 'Z'; + + PROCEDURE P1 IS NEW P (CHAR1); + PROCEDURE P2 IS NEW P (CHAR2); + PROCEDURE P3 IS NEW P (NEWCHAR); + BEGIN + P1 ("CHAR1", 3); + P2 ("CHAR2", 3); + P3 ("NEWCHAR", 3); + END; + + DECLARE + SUBTYPE NONGRAPH IS CHARACTER + RANGE CHARACTER'VAL (0) .. CHARACTER'VAL (31); + + MAX : INTEGER := 0; + + PROCEDURE PN IS NEW P (NONGRAPH); + BEGIN + FOR CH IN NONGRAPH + LOOP + IF CHARACTER'IMAGE (CH)'LENGTH > MAX THEN + MAX := CHARACTER'IMAGE (CH)'LENGTH; + END IF; + END LOOP; + + PN ("NONGRAPH", MAX); + END; + + RESULT; +END C35507B; diff --git a/gcc-4.9/gcc/testsuite/ada/acats/tests/c3/c35507c.ada b/gcc-4.9/gcc/testsuite/ada/acats/tests/c3/c35507c.ada new file mode 100644 index 000000000..386e5a36f --- /dev/null +++ b/gcc-4.9/gcc/testsuite/ada/acats/tests/c3/c35507c.ada @@ -0,0 +1,360 @@ +-- C35507C.ADA + +-- Grant of Unlimited Rights +-- +-- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687, +-- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained +-- unlimited rights in the software and documentation contained herein. +-- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making +-- this public release, the Government intends to confer upon all +-- recipients unlimited rights equal to those held by the Government. +-- These rights include rights to use, duplicate, release or disclose the +-- released technical data and computer software in whole or in part, in +-- any manner and for any purpose whatsoever, and to have or permit others +-- to do so. +-- +-- DISCLAIMER +-- +-- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR +-- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED +-- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF 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 ATTRIBUTES 'IMAGE' AND 'VALUE' YIELD THE CORRECT +-- RESULTS WHEN THE PREFIX IS A CHARACTER TYPE. +-- SUBTESTS ARE: +-- (A). TESTS FOR IMAGE. +-- (B). TESTS FOR VALUE. + +-- HISTORY: +-- RJW 05/29/86 CREATED ORIGINAL TEST. +-- BCB 08/18/87 CHANGED HEADER TO STANDARD HEADER FORMAT. +-- CORRECTED ERROR MESSAGES AND ADDED CALLS TO +-- IDENT_STR. + +WITH REPORT; USE REPORT; + +PROCEDURE C35507C IS + + TYPE CHAR IS ('A', 'a'); + + TYPE NEWCHAR IS NEW CHAR; + + FUNCTION IDENT (CH : CHAR) RETURN CHAR IS + BEGIN + RETURN CHAR'VAL (IDENT_INT (CHAR'POS (CH))); + END IDENT; + + FUNCTION IDENT (CH : NEWCHAR) RETURN NEWCHAR IS + BEGIN + RETURN NEWCHAR'VAL (IDENT_INT (NEWCHAR'POS (CH))); + END IDENT; + + PROCEDURE CHECK_BOUND (STR1, STR2 : STRING) IS + BEGIN + IF STR1'FIRST /= 1 THEN + FAILED ( "INCORRECT LOWER BOUND FOR " & STR2 & + "'IMAGE ('" & STR1 & "')" ); + END IF; + END CHECK_BOUND; + +BEGIN + + TEST( "C35507C" , "CHECK THAT THE ATTRIBUTES 'IMAGE' AND " & + "'VALUE' YIELD THE CORRECT RESULTS WHEN THE " & + "PREFIX IS A CHARACTER TYPE" ); + + BEGIN -- (A). + IF CHAR'IMAGE ('A') /= "'A'" THEN + FAILED ( "INCORRECT IMAGE FOR CHAR'('A')" ); + END IF; + + CHECK_BOUND (CHAR'IMAGE ('A'), "CHAR"); + + IF CHAR'IMAGE ('a') /= "'a'" THEN + FAILED ( "INCORRECT IMAGE FOR CHAR'('a')" ); + END IF; + + CHECK_BOUND (CHAR'IMAGE ('a'), "CHAR"); + + IF NEWCHAR'IMAGE ('A') /= "'A'" THEN + FAILED ( "INCORRECT IMAGE FOR NEWCHAR'('A')" ); + END IF; + + CHECK_BOUND (NEWCHAR'IMAGE ('A'), "NEWCHAR"); + + IF NEWCHAR'IMAGE ('a') /= "'a'" THEN + FAILED ( "INCORRECT IMAGE FOR NEWCHAR'('a')" ); + END IF; + + CHECK_BOUND (NEWCHAR'IMAGE ('a'), "NEWCHAR"); + + IF CHAR'IMAGE (IDENT ('A')) /= "'A'" THEN + FAILED ( "INCORRECT IMAGE FOR CHAR'( IDENT ('A'))" ); + END IF; + + CHECK_BOUND (CHAR'IMAGE (IDENT ('A')), "IDENT OF CHAR"); + + IF CHAR'IMAGE (IDENT ('a')) /= "'a'" THEN + FAILED ( "INCORRECT IMAGE FOR CHAR'( IDENT ('a'))" ); + END IF; + + CHECK_BOUND (CHAR'IMAGE (IDENT ('a')), "IDENT OF CHAR"); + + IF NEWCHAR'IMAGE (IDENT ('A')) /= "'A'" THEN + FAILED ( "INCORRECT IMAGE FOR NEWCHAR'( IDENT ('A'))" ); + END IF; + + CHECK_BOUND (NEWCHAR'IMAGE (IDENT ('A')), "IDENT OF NEWCHAR"); + + IF NEWCHAR'IMAGE (IDENT ('a')) /= "'a'" THEN + FAILED ( "INCORRECT IMAGE FOR NEWCHAR'( IDENT ('a'))" ); + END IF; + + CHECK_BOUND (NEWCHAR'IMAGE (IDENT ('a')), "IDENT OF NEWCHAR"); + + FOR CH IN CHARACTER'VAL (32) .. CHARACTER'VAL (126) LOOP + IF CHARACTER'IMAGE (CH) /= ("'" & CH) & "'" THEN + FAILED ( "INCORRECT IMAGE FOR CHARACTER'(" & + CH & ")" ); + END IF; + + CHECK_BOUND (CHARACTER'IMAGE (CH), "CHARACTER"); + + END LOOP; + + FOR CH IN CHARACTER'VAL (0) .. CHARACTER'VAL (31) LOOP + CHECK_BOUND (CHARACTER'IMAGE (CH), "CHARACTER"); + END LOOP; + + CHECK_BOUND (CHARACTER'IMAGE (CHARACTER'VAL (127)), + "CHARACTER"); + + END; + + --------------------------------------------------------------- + + DECLARE -- (B). + + SUBTYPE SUBCHAR IS CHARACTER + RANGE CHARACTER'VAL (127) .. CHARACTER'VAL (127); + BEGIN + FOR CH IN CHARACTER'VAL (32) .. CHARACTER'VAL (126) LOOP + IF SUBCHAR'VALUE (("'" & CH) & "'") /= CH THEN + FAILED ( "INCORRECT SUBCHAR'VALUE FOR " & CH ); + END IF; + END LOOP; + + FOR CH IN CHARACTER'VAL (0) .. CHARACTER'VAL (31) LOOP + IF SUBCHAR'VALUE (CHARACTER'IMAGE (CH)) /= CH THEN + FAILED ( "INCORRECT SUBCHAR'VALUE FOR " & + CHARACTER'IMAGE (CH) ); + END IF; + END LOOP; + + IF SUBCHAR'VALUE (CHARACTER'IMAGE (CHARACTER'VAL (127))) /= + CHARACTER'VAL (127) THEN + FAILED ( "INCORRECT SUBCHAR'VALUE FOR " & + "CHARACTER'VAL (127)" ); + END IF; + END; + + BEGIN + IF CHAR'VALUE ("'A'") /= 'A' THEN + FAILED ( "INCORRECT VALUE FOR CHAR'(""'A'"")" ); + END IF; + + IF CHAR'VALUE ("'a'") /= 'a' THEN + FAILED ( "INCORRECT VALUE FOR CHAR'(""'a'"")" ); + END IF; + + IF NEWCHAR'VALUE ("'A'") /= 'A' THEN + FAILED ( "INCORRECT VALUE FOR NEWCHAR'(""'A'"")" ); + END IF; + + IF NEWCHAR'VALUE ("'a'") /= 'a' THEN + FAILED ( "INCORRECT VALUE FOR NEWCHAR'(""'a'"")" ); + END IF; + END; + + BEGIN + IF CHAR'VALUE (IDENT_STR("'A'")) /= 'A' THEN + FAILED ( "INCORRECT VALUE FOR CHAR'(IDENT_STR" & + "(""'A'""))" ); + END IF; + + IF CHAR'VALUE (IDENT_STR("'a'")) /= 'a' THEN + FAILED ( "INCORRECT VALUE FOR CHAR'(IDENT_STR" & + "(""'a'""))" ); + END IF; + + IF NEWCHAR'VALUE (IDENT_STR("'A'")) /= 'A' THEN + FAILED ( "INCORRECT VALUE FOR NEWCHAR'(IDENT_STR" & + "(""'A'""))" ); + END IF; + + IF NEWCHAR'VALUE (IDENT_STR("'a'")) /= 'a' THEN + FAILED ( "INCORRECT VALUE FOR NEWCHAR'(IDENT_STR" & + "(""'a'""))" ); + END IF; + END; + + BEGIN + IF CHAR'VALUE (IDENT_STR ("'B'")) = 'A' THEN + FAILED ( "NO EXCEPTION RAISED " & + "FOR CHAR'VALUE (IDENT_STR (""'B'"")) - 1" ); + ELSE + FAILED ( "NO EXCEPTION RAISED " & + "FOR CHAR'VALUE (IDENT_STR (""'B'"")) - 2" ); + END IF; + EXCEPTION + WHEN CONSTRAINT_ERROR => + NULL; + WHEN OTHERS => + FAILED ( "WRONG EXCEPTION RAISED " & + "FOR CHAR'VALUE (IDENT_STR (""'B'""))" ); + END; + + BEGIN + IF CHARACTER'VALUE (IDENT_CHAR (ASCII.HT) & "'A'") = 'A' THEN + FAILED ( "NO EXCEPTION RAISED FOR " & + "CHARACTER'VALUE " & + "(IDENT_CHAR (ASCII.HT) & ""'A'"") - 1" ); + ELSE + FAILED ( "NO EXCEPTION RAISED FOR " & + "CHARACTER'VALUE " & + "(IDENT_CHAR (ASCII.HT) & ""'A'"") - 2" ); + END IF; + EXCEPTION + WHEN CONSTRAINT_ERROR => + NULL; + WHEN OTHERS => + FAILED ( "WRONG EXCEPTION RAISED " & + "FOR CHARACTER'VALUE " & + "(IDENT_CHAR (ASCII.HT) & ""'A'"")" ); + END; + + BEGIN + IF CHARACTER'VALUE ("'B'" & IDENT_CHAR (ASCII.HT)) = 'B' THEN + FAILED ( "NO EXCEPTION RAISED FOR " & + "CHARACTER'VALUE (""'B'"" & " & + "IDENT_CHAR (ASCII.HT)) - 1" ); + ELSE + FAILED ( "NO EXCEPTION RAISED FOR " & + "CHARACTER'VALUE (""'B'"" & " & + "IDENT_CHAR (ASCII.HT)) - 2" ); + END IF; + EXCEPTION + WHEN CONSTRAINT_ERROR => + NULL; + WHEN OTHERS => + FAILED ( "WRONG EXCEPTION RAISED " & + "FOR CHARACTER'VALUE (""'B'"" & " & + "IDENT_CHAR (ASCII.HT)) " ); + END; + + BEGIN + IF CHARACTER'VALUE ("'C'" & IDENT_CHAR (ASCII.BEL)) = 'C' + THEN + FAILED ( "NO EXCEPTION RAISED FOR " & + "CHARACTER'VALUE (""'C'"" & " & + "IDENT_CHAR (ASCII.BEL)) - 1" ); + ELSE + FAILED ( "NO EXCEPTION RAISED FOR " & + "CHARACTER'VALUE (""'C'"" & " & + "IDENT_CHAR (ASCII.BEL)) - 2" ); + END IF; + EXCEPTION + WHEN CONSTRAINT_ERROR => + NULL; + WHEN OTHERS => + FAILED ( "WRONG EXCEPTION RAISED " & + "FOR CHARACTER'VALUE (""'C'"" & " & + "IDENT_CHAR (ASCII.BEL))" ); + END; + + BEGIN + IF CHARACTER'VALUE (IDENT_STR ("'")) = ''' THEN + FAILED ( "NO EXCEPTION RAISED FOR " & + "CHARACTER'VALUE (IDENT_STR (""'"")) - 1" ); + ELSE + FAILED ( "NO EXCEPTION RAISED FOR " & + "CHARACTER'VALUE (IDENT_STR (""'"")) - 2" ); + END IF; + EXCEPTION + WHEN CONSTRAINT_ERROR => + NULL; + WHEN OTHERS => + FAILED ( "WRONG EXCEPTION RAISED " & + "FOR CHARACTER'VALUE (IDENT_STR (""'""))" ); + END; + + BEGIN + IF CHARACTER'VALUE (IDENT_STR ("''")) = ''' THEN + FAILED ( "NO EXCEPTION RAISED FOR " & + "CHARACTER'VALUE (IDENT_STR (""''"")) - 1" ); + ELSE + FAILED ( "NO EXCEPTION RAISED FOR " & + "CHARACTER'VALUE (IDENT_STR (""''"")) - 2" ); + END IF; + EXCEPTION + WHEN CONSTRAINT_ERROR => + NULL; + WHEN OTHERS => + FAILED ( "WRONG EXCEPTION RAISED " & + "FOR CHARACTER'VALUE (IDENT_STR (""''""))" ); + END; + + BEGIN + IF CHARACTER'VALUE (IDENT_STR ("'A")) = 'A' THEN + FAILED ( "NO EXCEPTION RAISED FOR " & + "CHARACTER'VALUE (IDENT_STR (""'A"")) - 1" ); + ELSE + FAILED ( "NO EXCEPTION RAISED FOR " & + "CHARACTER'VALUE (IDENT_STR (""'A"")) - 2" ); + END IF; + EXCEPTION + WHEN CONSTRAINT_ERROR => + NULL; + WHEN OTHERS => + FAILED ( "WRONG EXCEPTION RAISED " & + "FOR CHARACTER'VALUE IDENT_STR (""'A""))" ); + END; + + BEGIN + IF CHARACTER'VALUE (IDENT_STR ("A'")) = 'A' THEN + FAILED ( "NO EXCEPTION RAISED FOR " & + "CHARACTER'VALUE (IDENT_STR (""A'"")) - 1" ); + ELSE + FAILED ( "NO EXCEPTION RAISED FOR " & + "CHARACTER'VALUE (IDENT_STR (""A'"")) - 2" ); + END IF; + EXCEPTION + WHEN CONSTRAINT_ERROR => + NULL; + WHEN OTHERS => + FAILED ( "WRONG EXCEPTION RAISED " & + "FOR CHARACTER'VALUE (IDENT_STR (""A'""))" ); + END; + + BEGIN + IF CHARACTER'VALUE (IDENT_STR ("'AB'")) = 'A' THEN + FAILED ( "NO EXCEPTION RAISED FOR " & + "CHARACTER'VALUE (IDENT_STR (""'AB'"")) - 1" ); + ELSE + FAILED ( "NO EXCEPTION RAISED FOR " & + "CHARACTER'VALUE (IDENT_STR (""'AB'"")) - 2" ); + END IF; + EXCEPTION + WHEN CONSTRAINT_ERROR => + NULL; + WHEN OTHERS => + FAILED ( "WRONG EXCEPTION RAISED " & + "FOR CHARACTER'VALUE IDENT_STR (""'AB'""))" ); + END; + + RESULT; +END C35507C; diff --git a/gcc-4.9/gcc/testsuite/ada/acats/tests/c3/c35507e.ada b/gcc-4.9/gcc/testsuite/ada/acats/tests/c3/c35507e.ada new file mode 100644 index 000000000..93979902c --- /dev/null +++ b/gcc-4.9/gcc/testsuite/ada/acats/tests/c3/c35507e.ada @@ -0,0 +1,194 @@ +-- C35507E.ADA + +-- Grant of Unlimited Rights +-- +-- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687, +-- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained +-- unlimited rights in the software and documentation contained herein. +-- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making +-- this public release, the Government intends to confer upon all +-- recipients unlimited rights equal to those held by the Government. +-- These rights include rights to use, duplicate, release or disclose the +-- released technical data and computer software in whole or in part, in +-- any manner and for any purpose whatsoever, and to have or permit others +-- to do so. +-- +-- DISCLAIMER +-- +-- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR +-- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED +-- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF 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 ATTRIBUTES 'IMAGE' AND 'VALUE YIELD THE CORRECT +-- RESULTS WHEN THE PREFIX IS A FORMAL DISCRETE TYPE WHOSE ACTUAL +-- PARAMETER IS A CHARACTER TYPE. +-- SUBTESTS ARE: +-- (A). TESTS FOR IMAGE. +-- (B). TESTS FOR VALUE. + +-- HISTORY: +-- RJW 05/29/86 CREATED ORIGINAL TEST. +-- VCL 10/23/87 MODIFIED THIS HEADER, CHANGED THE CALLS TO +-- PROCEDURE 'PCH', IN THE SECOND PART OF SUBTEST B, +-- TO INCLUDE ANOTHER CALL TO PROCEDURE 'PCHAR' AND +-- CALLS TO PROCEDURE 'PNCHAR'. + +WITH REPORT; USE REPORT; +PROCEDURE C35507E IS + + TYPE CHAR IS ('A', 'a'); + + TYPE NEWCHAR IS NEW CHAR; + + PROCEDURE CHECK_LOWER_BOUND (STR1, STR2 : STRING) IS + BEGIN + IF STR1'FIRST /= 1 THEN + FAILED ( "INCORRECT LOWER BOUND FOR " & STR2 & "'(" & + STR1 & ")" ); + END IF; + END CHECK_LOWER_BOUND; + +BEGIN + + TEST( "C35507E" , "THE ATTRIBUTES 'IMAGE' AND " & + "'VALUE' YIELD THE CORRECT RESULTS WHEN THE " & + "PREFIX IS A FORMAL DISCRETE TYPE WHOSE " & + "ACTUAL PARAMETER IS A CHARACTER TYPE" ); + + DECLARE -- (A). + GENERIC + TYPE CHTYPE IS (<>); + STR1 : STRING; + PROCEDURE P (CH : CHTYPE; STR2 : STRING); + + PROCEDURE P (CH : CHTYPE; STR2 : STRING) IS + SUBTYPE SUBCH IS CHTYPE; + BEGIN + IF SUBCH'IMAGE (CH) /= STR2 THEN + FAILED ( "INCORRECT IMAGE FOR " & STR1 & "'(" & + STR2 & ")" ); + END IF; + + CHECK_LOWER_BOUND (SUBCH'IMAGE (CH), STR1); + END P; + + PROCEDURE PCHAR IS NEW P (CHAR, "CHAR"); + PROCEDURE PNCHAR IS NEW P (NEWCHAR, "NEWCHAR"); + PROCEDURE PCH IS NEW P (CHARACTER, "CHARACTER"); + + BEGIN + PCHAR ('A', "'A'"); + PCHAR ('a', "'a'"); + PNCHAR ('A', "'A'"); + PNCHAR ('a', "'a'"); + + FOR CH IN CHARACTER'VAL (32) .. CHARACTER'VAL (126) LOOP + PCH (CH, ("'" & CH) & "'" ); + END LOOP; + END; + + DECLARE + + GENERIC + TYPE CHTYPE IS (<>); + PROCEDURE P (CH : CHTYPE; STR : STRING); + + PROCEDURE P (CH : CHTYPE; STR : STRING) IS + SUBTYPE SUBCH IS CHTYPE; + BEGIN + CHECK_LOWER_BOUND (CHTYPE'IMAGE (CH), "CHARACTER"); + END P; + + PROCEDURE PN IS NEW P (CHARACTER); + + BEGIN + + FOR CH IN CHARACTER'VAL (0) .. CHARACTER'VAL (31) LOOP + PN (CH, CHARACTER'IMAGE (CH)); + END LOOP; + + PN (ASCII.DEL, CHARACTER'IMAGE (ASCII.DEL)); + END; + + --------------------------------------------------------------- + + DECLARE -- (B). + + GENERIC + TYPE CHTYPE IS (<>); + STR1 : STRING; + PROCEDURE P (STR2 : STRING; CH : CHTYPE); + + PROCEDURE P (STR2 : STRING; CH : CHTYPE) IS + SUBTYPE SUBCH IS CHTYPE; + BEGIN + IF SUBCH'VALUE (STR2) /= CH THEN + FAILED ( "INCORRECT " & STR1 & "'VALUE FOR " & + STR2 ); + END IF; + END P; + + PROCEDURE PCH IS NEW P (CHARACTER, "CHARACTER"); + PROCEDURE PCHAR IS NEW P (CHAR, "CHAR"); + PROCEDURE PNCHAR IS NEW P (NEWCHAR, "NEWCHAR"); + + BEGIN + FOR CH IN CHARACTER'VAL (0) .. CHARACTER'VAL (31) LOOP + PCH (CHARACTER'IMAGE (CH), CH ); + END LOOP; + + PCH (CHARACTER'IMAGE (CHARACTER'VAL (127)), + CHARACTER'VAL (127)); + + PCHAR ("'A'", 'A'); + PCHAR ("'a'", 'a' ); + PNCHAR ("'A'", 'A'); + PNCHAR ("'a'", 'a'); + END; + + DECLARE + GENERIC + TYPE CHTYPE IS (<>); + STR1 : STRING; + PROCEDURE P (STR2 : STRING); + + PROCEDURE P (STR2 : STRING) IS + SUBTYPE SUBCH IS CHTYPE; + BEGIN + IF SUBCH'VALUE (STR2) = SUBCH'VAL (0) THEN + FAILED ( "NO EXCEPTION RAISED FOR " & + STR1 & "'VALUE (" & STR2 & ") - 1" ); + ELSE + FAILED ( "NO EXCEPTION RAISED FOR " & + STR1 & "'VALUE (" & STR2 & ") - 2" ); + END IF; + EXCEPTION + WHEN CONSTRAINT_ERROR => + NULL; + WHEN OTHERS => + FAILED ( "WRONG EXCEPTION RAISED " & + "FOR " & STR1 & "'VALUE (" & STR2 & ")" ); + END P; + + PROCEDURE PCH IS NEW P (CHARACTER, "CHARACTER"); + PROCEDURE PCHAR IS NEW P (CHAR, "CHAR"); + PROCEDURE PNCHAR IS NEW P (NEWCHAR, "NEWCHAR"); + + BEGIN + PCHAR ("'B'"); + PCH (ASCII.HT & "'A'"); + PCH ("'B'" & ASCII.HT); + PCH ("'C'" & ASCII.BEL); + PCH ("'"); + PNCHAR ("''"); + PCHAR ("'A"); + PNCHAR ("A'"); + PCH ("'AB'"); + END; + + RESULT; +END C35507E; diff --git a/gcc-4.9/gcc/testsuite/ada/acats/tests/c3/c35507g.ada b/gcc-4.9/gcc/testsuite/ada/acats/tests/c3/c35507g.ada new file mode 100644 index 000000000..a1d8ecec4 --- /dev/null +++ b/gcc-4.9/gcc/testsuite/ada/acats/tests/c3/c35507g.ada @@ -0,0 +1,96 @@ +-- C35507G.ADA + +-- Grant of Unlimited Rights +-- +-- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687, +-- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained +-- unlimited rights in the software and documentation contained herein. +-- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making +-- this public release, the Government intends to confer upon all +-- recipients unlimited rights equal to those held by the Government. +-- These rights include rights to use, duplicate, release or disclose the +-- released technical data and computer software in whole or in part, in +-- any manner and for any purpose whatsoever, and to have or permit others +-- to do so. +-- +-- DISCLAIMER +-- +-- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR +-- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED +-- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF 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 ATTRIBUTES 'PRED' AND 'SUCC' YIELD THE CORRECT +-- RESULTS WHEN THE PREFIX IS A CHARACTER TYPE. + +-- HISTORY: +-- RJW 06/03/86 CREATED ORIGINAL TEST. +-- JET 08/13/87 REMOVED TESTS INTENDED FOR C35505F. + +WITH REPORT; USE REPORT; + +PROCEDURE C35507G IS + + TYPE CHAR IS ('A', B); + + TYPE NEWCHAR IS NEW CHAR; + + FUNCTION IDENT (CH : CHAR) RETURN CHAR IS + BEGIN + RETURN CHAR'VAL (IDENT_INT (CHAR'POS (CH))); + END; + + FUNCTION IDENT (CH : NEWCHAR) RETURN NEWCHAR IS + BEGIN + RETURN NEWCHAR'VAL (IDENT_INT (NEWCHAR'POS (CH))); + END; + +BEGIN + + TEST( "C35507G" , "CHECK THAT THE ATTRIBUTES 'PRED' AND " & + "'SUCC' YIELD THE CORRECT RESULTS WHEN THE " & + "PREFIX IS A CHARACTER TYPE" ); + + BEGIN + IF CHAR'SUCC ('A') /= B THEN + FAILED ( "INCORRECT VALUE FOR CHAR'SUCC('A')" ); + END IF; + + IF CHAR'PRED (IDENT (B)) /= 'A' THEN + FAILED ( "INCORRECT VALUE FOR CHAR'PRED (IDENT (B))" ); + END IF; + END; + + BEGIN + IF NEWCHAR'SUCC (IDENT ('A')) /= B THEN + FAILED ( "INCORRECT VALUE FOR " & + "IDENT (NEWCHAR'SUCC('A'))" ); + END IF; + + IF NEWCHAR'PRED (B) /= 'A' THEN + FAILED ( "INCORRECT VALUE FOR NEWCHAR'PRED(B)" ); + END IF; + END; + + FOR CH IN CHARACTER'VAL (1) .. CHARACTER'VAL (127) LOOP + IF CHARACTER'PRED (CH) /= + CHARACTER'VAL (CHARACTER'POS (CH) - 1) THEN + FAILED ( "INCORRECT VALUE FOR CHARACTER'PRED OF " & + CHARACTER'IMAGE (CH) ); + END IF; + END LOOP; + + FOR CH IN CHARACTER'VAL (0) .. CHARACTER'VAL (126) LOOP + IF CHARACTER'SUCC (CH) /= + CHARACTER'VAL (CHARACTER'POS (CH) + 1) THEN + FAILED ( "INCORRECT VALUE FOR CHARACTER'SUCC OF " & + CHARACTER'IMAGE (CH) ); + END IF; + END LOOP; + + RESULT; + +END C35507G; diff --git a/gcc-4.9/gcc/testsuite/ada/acats/tests/c3/c35507h.ada b/gcc-4.9/gcc/testsuite/ada/acats/tests/c3/c35507h.ada new file mode 100644 index 000000000..053b20c71 --- /dev/null +++ b/gcc-4.9/gcc/testsuite/ada/acats/tests/c3/c35507h.ada @@ -0,0 +1,89 @@ +-- C35507H.ADA + +-- Grant of Unlimited Rights +-- +-- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687, +-- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained +-- unlimited rights in the software and documentation contained herein. +-- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making +-- this public release, the Government intends to confer upon all +-- recipients unlimited rights equal to those held by the Government. +-- These rights include rights to use, duplicate, release or disclose the +-- released technical data and computer software in whole or in part, in +-- any manner and for any purpose whatsoever, and to have or permit others +-- to do so. +-- +-- DISCLAIMER +-- +-- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR +-- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED +-- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF 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 ATTRIBUTES 'PRED' AND 'SUCC' YIELD THE CORRECT +-- RESULTS WHEN THE PREFIX IS A FORMAL DISCRETE TYPE WHOSE ACTUAL +-- PARAMETER IS A CHARACTER TYPE. + +-- RJW 6/03/86 +-- DWC 7/01/87 -- ADDED THIRD VALUE TO CHAR TYPE. + -- REMOVED SECTION OF CODE AND PLACED INTO + -- C35505E.ADA. + +WITH REPORT; USE REPORT; + +PROCEDURE C35507H IS + + TYPE CHAR IS ('A', B, C); + + TYPE NEWCHAR IS NEW CHAR; + +BEGIN + + TEST( "C35507H" , "CHECK THAT THE ATTRIBUTES 'PRED' AND " & + "'SUCC' YIELD THE CORRECT RESULTS WHEN THE " & + "PREFIX IS A FORMAL DISCRETE TYPE WHOSE " & + "ACTUAL PARAMETER IS A CHARACTER TYPE" ); + + DECLARE + GENERIC + TYPE CHTYPE IS (<>); + STR : STRING; + I1, I2 : INTEGER; + PROCEDURE P; + + PROCEDURE P IS + SUBTYPE SUBCH IS CHTYPE + RANGE CHTYPE'VAL (I1) .. CHTYPE'VAL (I2); + + BEGIN + FOR CH IN SUBCH'VAL (I1 + 1) .. SUBCH'VAL (I2) LOOP + IF SUBCH'PRED (CH) /= + SUBCH'VAL (SUBCH'POS (CH) - 1) THEN + FAILED ( "INCORRECT VALUE FOR " & STR & + "'PRED OF " & SUBCH'IMAGE (CH) ); + END IF; + END LOOP; + + FOR CH IN SUBCH'VAL (I1) .. SUBCH'VAL (I2 - 1) LOOP + IF SUBCH'SUCC (CH) /= + SUBCH'VAL (SUBCH'POS (CH) + 1) THEN + FAILED ( "INCORRECT VALUE FOR " & STR & + "'SUCC OF " & SUBCH'IMAGE (CH) ); + END IF; + END LOOP; + + END P; + + PROCEDURE PCHAR IS NEW P (CHAR, "CHAR", 0, 1); + PROCEDURE PNCHAR IS NEW P (NEWCHAR, "NEWCHAR", 0, 1); + PROCEDURE PCH IS NEW P (CHARACTER, "CHARACTER", 0, 127); + BEGIN + PCHAR; + PNCHAR; + PCH; + END; + + RESULT; +END C35507H; diff --git a/gcc-4.9/gcc/testsuite/ada/acats/tests/c3/c35507i.ada b/gcc-4.9/gcc/testsuite/ada/acats/tests/c3/c35507i.ada new file mode 100644 index 000000000..e2318d7b2 --- /dev/null +++ b/gcc-4.9/gcc/testsuite/ada/acats/tests/c3/c35507i.ada @@ -0,0 +1,84 @@ +-- C35507I.ADA + +-- Grant of Unlimited Rights +-- +-- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687, +-- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained +-- unlimited rights in the software and documentation contained herein. +-- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making +-- this public release, the Government intends to confer upon all +-- recipients unlimited rights equal to those held by the Government. +-- These rights include rights to use, duplicate, release or disclose the +-- released technical data and computer software in whole or in part, in +-- any manner and for any purpose whatsoever, and to have or permit others +-- to do so. +-- +-- DISCLAIMER +-- +-- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR +-- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED +-- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF 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 ATTRIBUTES 'PRED' AND 'SUCC' YIELD THE CORRECT +-- RESULTS WHEN THE PREFIX IS A CHARACTER TYPE WITH AN ENUMERATION +-- REPRESENTATION CLAUSE. + +-- HISTORY: +-- RJW 06/03/86 CREATED ORIGINAL TEST. +-- PWB 05/11/89 CHANGED EXTENSION FROM '.DEP' TO '.ADA'. +-- DTN 11/26/91 DELETED CONSTRAINT_ERROR FOR ATTRIBUTES PRED AND +-- SUCC SUBTESTS. + +WITH REPORT; USE REPORT; + +PROCEDURE C35507I IS + + TYPE CHAR IS ('A', B); + FOR CHAR USE ('A' => 2, B => 5); + + TYPE NEWCHAR IS NEW CHAR; + + FUNCTION IDENT (CH : CHAR) RETURN CHAR IS + BEGIN + RETURN CHAR'VAL (IDENT_INT (CHAR'POS (CH))); + END; + + FUNCTION IDENT (CH : NEWCHAR) RETURN NEWCHAR IS + BEGIN + RETURN NEWCHAR'VAL (IDENT_INT (NEWCHAR'POS (CH))); + END; + +BEGIN + + TEST( "C35507I" , "CHECK THAT THE ATTRIBUTES 'PRED' AND " & + "'SUCC' YIELD THE CORRECT RESULTS WHEN THE " & + "PREFIX IS A CHARACTER TYPE WITH AN " & + "ENUMERATION REPRESENTATION CLAUSE" ); + + BEGIN + IF CHAR'SUCC ('A') /= B THEN + FAILED ( "INCORRECT VALUE FOR CHAR'SUCC('A')" ); + END IF; + + IF CHAR'PRED (IDENT (B)) /= 'A' THEN + FAILED ( "INCORRECT VALUE FOR CHAR'PRED (IDENT (B))" ); + END IF; + END; + + BEGIN + IF IDENT (NEWCHAR'SUCC ('A')) /= B THEN + FAILED ( "INCORRECT VALUE FOR " & + "IDENT (NEWCHAR'SUCC('A'))" ); + END IF; + + IF NEWCHAR'PRED (B) /= 'A' THEN + FAILED ( "INCORRECT VALUE FOR NEWCHAR'PRED(B)" ); + END IF; + END; + + RESULT; +END C35507I; diff --git a/gcc-4.9/gcc/testsuite/ada/acats/tests/c3/c35507j.ada b/gcc-4.9/gcc/testsuite/ada/acats/tests/c3/c35507j.ada new file mode 100644 index 000000000..9e9e89856 --- /dev/null +++ b/gcc-4.9/gcc/testsuite/ada/acats/tests/c3/c35507j.ada @@ -0,0 +1,93 @@ +-- C35507J.ADA + +-- Grant of Unlimited Rights +-- +-- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687, +-- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained +-- unlimited rights in the software and documentation contained herein. +-- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making +-- this public release, the Government intends to confer upon all +-- recipients unlimited rights equal to those held by the Government. +-- These rights include rights to use, duplicate, release or disclose the +-- released technical data and computer software in whole or in part, in +-- any manner and for any purpose whatsoever, and to have or permit others +-- to do so. +-- +-- DISCLAIMER +-- +-- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR +-- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED +-- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF 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 ATTRIBUTES 'PRED' AND 'SUCC' YIELD THE CORRECT +-- RESULTS WHEN THE PREFIX IS A FORMAL DISCRETE TYPE WHOSE ACTUAL +-- PARAMETER IS A CHARACTER TYPE WITH AN ENUMERATION REPRESENTATION +-- CLAUSE. + +-- HISTORY: +-- RJW 06/03/86 CREATED ORIGINAL TEST. +-- JET 09/22/87 MADE REPRESENTATION VALUES CONSECUTIVE. +-- PWB 05/11/89 CHANGED EXTENSION FROM '.DEP' TO '.ADA'. + +WITH REPORT; USE REPORT; + +PROCEDURE C35507J IS + + TYPE CHAR IS ('A', B); + FOR CHAR USE ('A' => 4, B => 5); + + TYPE NEWCHAR IS NEW CHAR; + +BEGIN + + TEST( "C35507J" , "CHECK THAT THE ATTRIBUTES 'PRED' AND " & + "'SUCC' YIELD THE CORRECT RESULTS WHEN THE " & + "PREFIX IS A FORMAL DISCRETE TYPE WHOSE " & + "ACTUAL PARAMETER IS A CHARACTER TYPE WITH " & + "WITH AN ENUMERATION REPRESENTATION CLAUSE" ); + + + DECLARE + GENERIC + TYPE CHTYPE IS (<>); + STR : STRING; + I1, I2 : INTEGER; + PROCEDURE P; + + PROCEDURE P IS + SUBTYPE SUBCH IS CHTYPE + RANGE CHTYPE'VAL (I1) .. CHTYPE'VAL (I2); + BEGIN + FOR CH IN SUBCH'VAL (I1 + 1) .. SUBCH'VAL (I2) LOOP + IF SUBCH'PRED (CH) /= + SUBCH'VAL (SUBCH'POS (CH) - 1) THEN + FAILED ( "INCORRECT VALUE FOR " & STR & + "'PRED OF " & SUBCH'IMAGE (CH) ); + END IF; + END LOOP; + + FOR CH IN SUBCH'VAL (I1) .. SUBCH'VAL (I2 - 1) LOOP + IF SUBCH'SUCC (CH) /= + SUBCH'VAL (SUBCH'POS (CH) + 1) THEN + FAILED ( "INCORRECT VALUE FOR " & STR & + "'SUCC OF " & SUBCH'IMAGE (CH) ); + END IF; + END LOOP; + + END P; + + PROCEDURE PCHAR IS NEW P (CHAR, "CHAR", 0, 1); + PROCEDURE PNCHAR IS NEW P (NEWCHAR, "NEWCHAR", 0, 1); + + BEGIN + PCHAR; + PNCHAR; + + END; + + RESULT; +END C35507J; diff --git a/gcc-4.9/gcc/testsuite/ada/acats/tests/c3/c35507k.ada b/gcc-4.9/gcc/testsuite/ada/acats/tests/c3/c35507k.ada new file mode 100644 index 000000000..b26399234 --- /dev/null +++ b/gcc-4.9/gcc/testsuite/ada/acats/tests/c3/c35507k.ada @@ -0,0 +1,224 @@ +-- C35507K.ADA + +-- Grant of Unlimited Rights +-- +-- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687, +-- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained +-- unlimited rights in the software and documentation contained herein. +-- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making +-- this public release, the Government intends to confer upon all +-- recipients unlimited rights equal to those held by the Government. +-- These rights include rights to use, duplicate, release or disclose the +-- released technical data and computer software in whole or in part, in +-- any manner and for any purpose whatsoever, and to have or permit others +-- to do so. +-- +-- DISCLAIMER +-- +-- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR +-- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED +-- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF 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 ATTRIBUTES 'POS' AND 'VAL' YIELD THE CORRECT +-- RESULTS WHEN THE PREFIX IS A CHARACTER TYPE. + +-- HISTORY: +-- RJW 06/03/86 +-- JLH 07/28/87 MODIFIED FUNCTION IDENT. +-- PWN 11/30/94 REMOVED PART OF TEST INVALID FOR ADA 9X. + +WITH REPORT; USE REPORT; + +PROCEDURE C35507K IS + + TYPE CHAR IS ('A', B); + + TYPE NEWCHAR IS NEW CHAR; + + SUBTYPE SCHAR IS CHARACTER + RANGE CHARACTER'VAL (127) .. CHARACTER'VAL (127); + + BLANK : CONSTANT CHARACTER := ' '; + + POSITION : INTEGER; + + NONGRAPH : ARRAY (0 .. 31) OF CHARACTER := + (ASCII.NUL, ASCII.SOH, ASCII.STX, ASCII.ETX, + ASCII.EOT, ASCII.ENQ, ASCII.ACK, ASCII.BEL, + ASCII.BS, ASCII.HT, ASCII.LF, ASCII.VT, + ASCII.FF, ASCII.CR, ASCII.SO, ASCII.SI, + ASCII.DLE, ASCII.DC1, ASCII.DC2, ASCII.DC3, + ASCII.DC4, ASCII.NAK, ASCII.SYN, ASCII.ETB, + ASCII.CAN, ASCII.EM, ASCII.SUB, ASCII.ESC, + ASCII.FS, ASCII.GS, ASCII.RS, ASCII.US); + + FUNCTION IDENT (CH : CHAR) RETURN CHAR IS + BEGIN + IF EQUAL (CHAR'POS (CH), CHAR'POS (CH)) THEN + RETURN CH; + END IF; + RETURN CHAR'FIRST; + END IDENT; + + FUNCTION IDENT (CH : NEWCHAR) RETURN NEWCHAR IS + BEGIN + IF EQUAL (NEWCHAR'POS (CH), NEWCHAR'POS (CH)) THEN + RETURN CH; + END IF; + RETURN NEWCHAR'FIRST; + END IDENT; + +BEGIN + + TEST( "C35507K" , "CHECK THAT THE ATTRIBUTES 'POS' AND " & + "'VAL' YIELD THE CORRECT RESULTS WHEN THE " & + "PREFIX IS A CHARACTER TYPE" ); + + BEGIN + IF CHAR'POS ('A') /= 0 THEN + FAILED ( "INCORRECT VALUE FOR CHAR'POS('A') - 1" ); + END IF; + + IF CHAR'POS (B) /= 1 THEN + FAILED ( "INCORRECT VALUE FOR CHAR'POS(B) - 1" ); + END IF; + + IF CHAR'VAL (0) /= 'A' THEN + FAILED ( "INCORRECT VALUE FOR CHAR'VAL(0)" ); + END IF; + + IF CHAR'VAL (1) /= B THEN + FAILED ( "INCORRECT VALUE FOR CHAR'VAL(1)" ); + END IF; + + IF CHAR'POS (IDENT ('A')) /= 0 THEN + FAILED ( "INCORRECT VALUE " & + "FOR CHAR'POS (IDENT ('A')) - 2" ); + END IF; + + IF CHAR'POS (IDENT (B)) /= 1 THEN + FAILED ( "INCORRECT VALUE " & + "FOR CHAR'POS (IDENT (B)) - 2" ); + END IF; + + END; + + BEGIN + IF NEWCHAR'POS ('A') /= 0 THEN + FAILED ( "INCORRECT VALUE FOR NEWCHAR'POS('A')" ); + END IF; + + IF NEWCHAR'POS (B) /= 1 THEN + FAILED ( "INCORRECT VALUE FOR NEWCHAR'POS(B) - 1" ); + END IF; + + IF NEWCHAR'VAL (0) /= 'A' THEN + FAILED ( "INCORRECT VALUE FOR NEWCHAR'VAL(0) - 1" ); + END IF; + + IF NEWCHAR'VAL (1) /= B THEN + FAILED ( "INCORRECT VALUE FOR NEWCHAR'VAL(1)" ); + END IF; + + IF NEWCHAR'VAL (IDENT_INT (1)) /= B THEN + FAILED ( "INCORRECT VALUE " & + "FOR NEWCHAR'POS (IDENT (B)) - 2" ); + END IF; + + IF (NEWCHAR'VAL (IDENT_INT(0))) /= 'A' THEN + FAILED ( "INCORRECT VALUE " & + "FOR IDENT (NEWCHAR'VAL (0)) - 2" ); + END IF; + + END; + + BEGIN + IF CHAR'VAL (IDENT_INT (2)) = B THEN + FAILED ( "NO EXCEPTION RAISED " & + "FOR CHAR'VAL (IDENT_INT (2)) - 1" ); + ELSE + FAILED ( "NO EXCEPTION RAISED " & + "FOR CHAR'VAL (IDENT_INT (2)) - 2" ); + END IF; + EXCEPTION + WHEN CONSTRAINT_ERROR => + NULL; + WHEN OTHERS => + FAILED ( "WRONG EXCEPTION RAISED " & + "FOR CHAR'VAL (IDENT_INT (2))" ); + END; + + BEGIN + IF NEWCHAR'VAL (IDENT_INT (-1)) = 'A' THEN + FAILED ( "NO EXCEPTION RAISED " & + "FOR NEWCHAR'VAL (IDENT_INT (-1)) - 1" ); + ELSE + FAILED ( "NO EXCEPTION RAISED " & + "FOR NEWCHAR'VAL (IDENT_INT (-1)) - 2" ); + END IF; + EXCEPTION + WHEN CONSTRAINT_ERROR => + NULL; + WHEN OTHERS => + FAILED ( "WRONG EXCEPTION RAISED " & + "FOR NEWCHAR'VAL (IDENT_INT (-1))" ); + END; + + POSITION := 0; + + FOR CH IN CHARACTER LOOP + IF SCHAR'POS (CH) /= POSITION THEN + FAILED ( "INCORRECT VALUE FOR SCHAR'POS OF " & + CHARACTER'IMAGE (CH) ); + END IF; + + POSITION := POSITION + 1; + END LOOP; + + FOR POSITION IN 0 .. 31 LOOP + IF CHARACTER'VAL (POSITION) /= NONGRAPH (POSITION) THEN + FAILED ( "INCORRECT VALUE FOR CHARACTER'VAL OF " & + "NONGRAPHIC CHARACTER IN POSITION - " & + INTEGER'IMAGE (POSITION) ); + END IF; + END LOOP; + + POSITION := 32; + + FOR CH IN BLANK .. ASCII.TILDE LOOP + IF SCHAR'VAL (POSITION) /= CH THEN + FAILED ( "INCORRECT VALUE FOR SCHAR'VAL OF " & + "GRAPHIC CHARACTER IN POSITION - " & + INTEGER'IMAGE (POSITION) ); + END IF; + + POSITION := POSITION + 1; + END LOOP; + + IF CHARACTER'VAL (127) /= ASCII.DEL THEN + FAILED ( "INCORRECT VALUE FOR CHARACTER'VAL OF " & + "NONGRAPHIC CHARACTER IN POSITION - 127" ); + END IF; + + BEGIN + IF CHARACTER'VAL (IDENT_INT (-1)) = ASCII.NUL THEN + FAILED ( "NO EXCEPTION RAISED " & + "FOR CHARACTER'VAL (IDENT_INT (-1)) - 1" ); + ELSE + FAILED ( "NO EXCEPTION RAISED " & + "FOR CHARACTER'VAL (IDENT_INT (-1)) - 2" ); + END IF; + EXCEPTION + WHEN CONSTRAINT_ERROR => + NULL; + WHEN OTHERS => + FAILED ( "WRONG EXCEPTION RAISED " & + "FOR CHARACTER'VAL (IDENT_INT (-1))" ); + END; + + RESULT; +END C35507K; diff --git a/gcc-4.9/gcc/testsuite/ada/acats/tests/c3/c35507l.ada b/gcc-4.9/gcc/testsuite/ada/acats/tests/c3/c35507l.ada new file mode 100644 index 000000000..a259c74f9 --- /dev/null +++ b/gcc-4.9/gcc/testsuite/ada/acats/tests/c3/c35507l.ada @@ -0,0 +1,101 @@ +-- C35507L.ADA + +-- Grant of Unlimited Rights +-- +-- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687, +-- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained +-- unlimited rights in the software and documentation contained herein. +-- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making +-- this public release, the Government intends to confer upon all +-- recipients unlimited rights equal to those held by the Government. +-- These rights include rights to use, duplicate, release or disclose the +-- released technical data and computer software in whole or in part, in +-- any manner and for any purpose whatsoever, and to have or permit others +-- to do so. +-- +-- DISCLAIMER +-- +-- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR +-- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED +-- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF 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 ATTRIBUTES 'POS' AND 'VAL' YIELD THE CORRECT +-- RESULTS WHEN THE PREFIX IS A FORMAL DISCRETE TYPE WHOSE ACTUAL +-- PARAMETER IS A CHARACTER TYPE. + +-- RJW 6/03/86 +-- PWN 11/30/94 REMOVED TESTS BASED ON 128 CHARACTERS FOR ADA 9X. + +WITH REPORT; USE REPORT; + +PROCEDURE C35507L IS + + TYPE CHAR IS ('A', B); + + TYPE NEWCHAR IS NEW CHAR; + +BEGIN + + TEST( "C35507L" , "CHECK THAT THE ATTRIBUTES 'POS' AND " & + "'VAL' YIELD THE CORRECT RESULTS WHEN THE " & + "PREFIX IS A FORMAL DISCRETE TYPE WHOSE " & + "ACTUAL PARAMETER IS A CHARACTER TYPE" ); + + DECLARE + GENERIC + TYPE CHTYPE IS (<>); + STR : STRING; + I1 : INTEGER; + PROCEDURE P; + + PROCEDURE P IS + SUBTYPE SUBCH IS CHTYPE; + CH : CHTYPE; + POSITION : INTEGER; + BEGIN + POSITION := 0; + FOR CH IN CHTYPE LOOP + IF SUBCH'POS (CH) /= POSITION THEN + FAILED ( "INCORRECT VALUE FOR " & STR & + "'POS OF " & CHTYPE'IMAGE (CH) ); + END IF; + + IF SUBCH'VAL (POSITION) /= CH THEN + FAILED ( "INCORRECT VALUE FOR " & STR & + "'VAL OF CHARACTER IN POSITION - " & + INTEGER'IMAGE (POSITION) ); + END IF; + POSITION := POSITION + 1; + END LOOP; + + BEGIN + IF SUBCH'VAL (-1) = SUBCH'VAL (0) THEN + FAILED ( "NO EXCEPTION RAISED " & + "FOR " & STR & "'VAL (-1) - 1" ); + ELSE + FAILED ( "NO EXCEPTION RAISED " & + "FOR " & STR & "'VAL (-1) - 2" ); + END IF; + EXCEPTION + WHEN CONSTRAINT_ERROR => + NULL; + WHEN OTHERS => + FAILED ( "WRONG EXCEPTION RAISED " & + "FOR " & STR & "'VAL (-1)" ); + END; + END P; + + PROCEDURE PCHAR IS NEW P (CHAR, "CHAR", 1); + PROCEDURE PNCHAR IS NEW P (NEWCHAR, "NEWCHAR", 1); + PROCEDURE PCH IS NEW P (CHARACTER, "CHARACTER", 127); + BEGIN + PCHAR; + PNCHAR; + PCH; + END; + + RESULT; +END C35507L; diff --git a/gcc-4.9/gcc/testsuite/ada/acats/tests/c3/c35507m.ada b/gcc-4.9/gcc/testsuite/ada/acats/tests/c3/c35507m.ada new file mode 100644 index 000000000..e76178c6c --- /dev/null +++ b/gcc-4.9/gcc/testsuite/ada/acats/tests/c3/c35507m.ada @@ -0,0 +1,159 @@ +-- C35507M.ADA + +-- Grant of Unlimited Rights +-- +-- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687, +-- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained +-- unlimited rights in the software and documentation contained herein. +-- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making +-- this public release, the Government intends to confer upon all +-- recipients unlimited rights equal to those held by the Government. +-- These rights include rights to use, duplicate, release or disclose the +-- released technical data and computer software in whole or in part, in +-- any manner and for any purpose whatsoever, and to have or permit others +-- to do so. +-- +-- DISCLAIMER +-- +-- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR +-- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED +-- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF 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 ATTRIBUTES 'POS' AND 'VAL' YIELD THE CORRECT +-- RESULTS WHEN THE PREFIX IS A CHARACTER TYPE WITH AN ENUMERATION +-- REPRESENTATION CLAUSE. + +-- HISTORY: +-- RJW 06/03/86 CREATED ORIGINAL TEST +-- JLH 07/28/87 MODIFIED FUNCTION IDENT. +-- PWB 05/11/89 CHANGED EXTENSION FROM '.DEP' TO '.ADA'. + +WITH REPORT; USE REPORT; + +PROCEDURE C35507M IS + + TYPE CHAR IS ('A', B); + FOR CHAR USE ('A' => 4, B => 5); + + TYPE NEWCHAR IS NEW CHAR; + + FUNCTION IDENT (CH : CHAR) RETURN CHAR IS + BEGIN + IF EQUAL (3,3) THEN + RETURN CH; + ELSE + RETURN 'A'; + END IF; + END IDENT; + + FUNCTION IDENT (CH : NEWCHAR) RETURN NEWCHAR IS + BEGIN + IF EQUAL (3,3) THEN + RETURN CH; + ELSE + RETURN 'A'; + END IF; + END IDENT; + +BEGIN + + TEST( "C35507M" , "CHECK THAT THE ATTRIBUTES 'POS' AND " & + "'VAL' YIELD THE CORRECT RESULTS WHEN THE " & + "PREFIX IS A CHARACTER TYPE WITH AN " & + "ENUMERATION REPESENTATION CLAUSE" ); + + BEGIN + IF CHAR'POS ('A') /= 0 THEN + FAILED ( "INCORRECT VALUE FOR CHAR'POS('A')" ); + END IF; + + IF CHAR'POS (B) /= 1 THEN + FAILED ( "INCORRECT VALUE FOR CHAR'POS(B)" ); + END IF; + + IF CHAR'VAL (0) /= 'A' THEN + FAILED ( "INCORRECT VALUE FOR CHAR'VAL(0)" ); + END IF; + + IF CHAR'VAL (1) /= B THEN + FAILED ( "INCORRECT VALUE FOR CHAR'VAL(1)" ); + END IF; + END; + + BEGIN + IF NEWCHAR'POS ('A') /= 0 THEN + FAILED ( "INCORRECT VALUE FOR NEWCHAR'POS('A')" ); + END IF; + + IF NEWCHAR'POS (B) /= 1 THEN + FAILED ( "INCORRECT VALUE FOR NEWCHAR'POS(B)" ); + END IF; + + IF NEWCHAR'VAL (0) /= 'A' THEN + FAILED ( "INCORRECT VALUE FOR NEWCHAR'VAL(0)" ); + END IF; + + IF NEWCHAR'VAL (1) /= B THEN + FAILED ( "INCORRECT VALUE FOR NEWCHAR'VAL(1)" ); + END IF; + END; + + BEGIN + IF CHAR'POS (IDENT ('A')) /= 0 THEN + FAILED ( "INCORRECT VALUE FOR CHAR'POS('A') WITH " & + "IDENT" ); + END IF; + + IF NEWCHAR'POS (IDENT (B)) /= 1 THEN + FAILED ( "INCORRECT VALUE FOR NEWCHAR'POS(B) WITH " & + "IDENT" ); + END IF; + + IF IDENT (NEWCHAR'VAL (IDENT_INT(0))) /= 'A' THEN + FAILED ( "INCORRECT VALUE FOR NEWCHAR'VAL(0) WITH " & + "IDENT" ); + END IF; + + IF IDENT (CHAR'VAL (IDENT_INT(1))) /= B THEN + FAILED ( "INCORRECT VALUE FOR CHAR'VAL(1) WITH IDENT" ); + END IF; + END; + + BEGIN + IF CHAR'VAL (IDENT_INT(2)) = B THEN + FAILED ( "NO EXCEPTION RAISED FOR " & + "CHAR'VAL (IDENT_INT(2)) - 1" ); + ELSE + FAILED ( "NO EXCEPTION RAISED FOR " & + "CHAR'VAL (IDENT_INT(2)) - 2" ); + END IF; + EXCEPTION + WHEN CONSTRAINT_ERROR => + NULL; + WHEN OTHERS => + FAILED ( "WRONG EXCEPTION RAISED FOR " & + "CHAR'VAL (IDENT_INT(2))" ); + END; + + BEGIN + IF NEWCHAR'VAL (IDENT_INT (-1)) = 'A' THEN + FAILED ( "NO EXCEPTION RAISED " & + "FOR NEWCHAR'VAL (IDENT_INT (-1)) - 1" ); + ELSE + FAILED ( "NO EXCEPTION RAISED " & + "FOR NEWCHAR'VAL (IDENT_INT (-1)) - 2" ); + END IF; + EXCEPTION + WHEN CONSTRAINT_ERROR => + NULL; + WHEN OTHERS => + FAILED ( "WRONG EXCEPTION RAISED " & + "FOR NEWCHAR'VAL (IDENT_INT (-1))" ); + END; + + RESULT; +END C35507M; diff --git a/gcc-4.9/gcc/testsuite/ada/acats/tests/c3/c35507n.ada b/gcc-4.9/gcc/testsuite/ada/acats/tests/c3/c35507n.ada new file mode 100644 index 000000000..1e5e48a3a --- /dev/null +++ b/gcc-4.9/gcc/testsuite/ada/acats/tests/c3/c35507n.ada @@ -0,0 +1,108 @@ +-- C35507N.ADA + +-- Grant of Unlimited Rights +-- +-- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687, +-- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained +-- unlimited rights in the software and documentation contained herein. +-- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making +-- this public release, the Government intends to confer upon all +-- recipients unlimited rights equal to those held by the Government. +-- These rights include rights to use, duplicate, release or disclose the +-- released technical data and computer software in whole or in part, in +-- any manner and for any purpose whatsoever, and to have or permit others +-- to do so. +-- +-- DISCLAIMER +-- +-- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR +-- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED +-- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF 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 ATTRIBUTES 'POS' AND 'VAL' YIELD THE CORRECT +-- RESULTS WHEN THE PREFIX IS A FORMAL DISCRETE TYPE WHOSE ACTUAL +-- PARAMETER IS A CHARACTER TYPE WITH AN ENUMERATION REPRESENTATION +-- CLAUSE. + +-- HISTORY: +-- RJW 06/03/86 CREATED ORIGINAL TEST. +-- JET 09/22/87 MADE REPRESENTATION VALUES CONSECUTIVE. +-- PWB 05/11/89 CHANGED EXTENSION FROM '.DEP' TO '.ADA'. +-- PWN 11/30/94 REMOVED TESTS BASED ON 128 CHARACTERS FOR ADA 9X. + +WITH REPORT; USE REPORT; + +PROCEDURE C35507N IS + + TYPE CHAR IS ('A', B); + FOR CHAR USE ('A' => 4, B => 5); + + TYPE NEWCHAR IS NEW CHAR; + +BEGIN + + TEST( "C35507N" , "CHECK THAT THE ATTRIBUTES 'POS' AND " & + "'VAL' YIELD THE CORRECT RESULTS WHEN THE " & + "PREFIX IS A FORMAL DISCRETE TYPE WHOSE " & + "ACTUAL PARAMETER IS A CHARACTER TYPE " & + "WITH AN ENUMERATION REPRESENTATION CLAUSE" ); + + DECLARE + GENERIC + TYPE CHTYPE IS (<>); + STR : STRING; + I1 : INTEGER; + PROCEDURE P; + + PROCEDURE P IS + SUBTYPE SUBCH IS CHTYPE; + CH : CHTYPE; + POSITION : INTEGER; + BEGIN + POSITION := 0; + FOR CH IN CHTYPE LOOP + IF SUBCH'POS (CH) /= POSITION THEN + FAILED ( "INCORRECT VALUE FOR " & STR & + "'POS OF " & CHTYPE'IMAGE (CH) ); + END IF; + + IF SUBCH'VAL (POSITION) /= CH THEN + FAILED ( "INCORRECT VALUE FOR " & STR & + "'VAL OF CHARACTER IN POSITION - " & + INTEGER'IMAGE (POSITION) ); + END IF; + POSITION := POSITION + 1; + END LOOP; + + BEGIN + IF SUBCH'VAL (-1) = SUBCH'VAL (0) THEN + FAILED ( "NO EXCEPTION RAISED " & + "FOR " & STR & "'VAL (-1) - 1" ); + ELSE + FAILED ( "NO EXCEPTION RAISED " & + "FOR " & STR & "'VAL (-1) - 2" ); + END IF; + EXCEPTION + WHEN CONSTRAINT_ERROR => + NULL; + WHEN OTHERS => + FAILED ( "WRONG EXCEPTION RAISED " & + "FOR " & STR & "'VAL (-1)" ); + END; + END P; + + PROCEDURE PCHAR IS NEW P (CHAR, "CHAR", 1); + PROCEDURE PNCHAR IS NEW P (NEWCHAR, "NEWCHAR", 1); + PROCEDURE PCH IS NEW P (CHARACTER, "CHARACTER", 127); + BEGIN + PCHAR; + PNCHAR; + PCH; + END; + + RESULT; +END C35507N; diff --git a/gcc-4.9/gcc/testsuite/ada/acats/tests/c3/c35507o.ada b/gcc-4.9/gcc/testsuite/ada/acats/tests/c3/c35507o.ada new file mode 100644 index 000000000..723a5ea11 --- /dev/null +++ b/gcc-4.9/gcc/testsuite/ada/acats/tests/c3/c35507o.ada @@ -0,0 +1,120 @@ +-- C35507O.ADA + +-- Grant of Unlimited Rights +-- +-- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687, +-- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained +-- unlimited rights in the software and documentation contained herein. +-- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making +-- this public release, the Government intends to confer upon all +-- recipients unlimited rights equal to those held by the Government. +-- These rights include rights to use, duplicate, release or disclose the +-- released technical data and computer software in whole or in part, in +-- any manner and for any purpose whatsoever, and to have or permit others +-- to do so. +-- +-- DISCLAIMER +-- +-- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR +-- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED +-- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF 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 ATTRIBUTES 'FIRST' AND 'LAST' YIELD THE CORRECT +-- RESULTS WHEN THE PREFIX IS A CHARACTER TYPE. + +-- RJW 6/03/86 +-- PWN 11/30/94 SUBTYPE QUALIFIED LITERALS FOR ADA 9X. +-- REMOVED PART OF TEST INVALID FOR ADA 9X. + +WITH REPORT; USE REPORT; + +PROCEDURE C35507O IS + + TYPE CHAR IS ('A', B); + + TYPE NEWCHAR IS NEW CHAR; + + SPACE : CONSTANT CHARACTER := CHARACTER'(' '); + + SUBTYPE NOCHAR IS CHARACTER RANGE CHARACTER'('Z') .. CHARACTER'('A'); + SUBTYPE GRAPHIC IS CHARACTER RANGE SPACE .. ASCII.TILDE; + SUBTYPE NONGRAPHIC IS CHARACTER RANGE ASCII.NUL .. ASCII.US; + + FUNCTION IDENT (CH : CHAR) RETURN CHAR IS + BEGIN + RETURN CHAR'VAL (IDENT_INT (CHAR'POS (CH))); + END IDENT; + + FUNCTION IDENT (CH : NEWCHAR) RETURN NEWCHAR IS + BEGIN + RETURN NEWCHAR'VAL (IDENT_INT (NEWCHAR'POS (CH))); + END IDENT; + +BEGIN + + TEST( "C35507O" , "CHECK THAT THE ATTRIBUTES 'FIRST' AND " & + "'LAST' YIELD THE CORRECT RESULTS WHEN THE " & + "PREFIX IS A CHARACTER TYPE" ); + + BEGIN + IF IDENT (CHAR'FIRST) /= 'A' THEN + FAILED ( "INCORRECT VALUE FOR CHAR'FIRST" ); + END IF; + + IF CHAR'LAST /= B THEN + FAILED ( "INCORRECT VALUE FOR CHAR'LAST" ); + END IF; + END; + + BEGIN + IF NEWCHAR'FIRST /= 'A' THEN + FAILED ( "INCORRECT VALUE FOR NEWCHAR'FIRST" ); + END IF; + + IF NEWCHAR'LAST /= IDENT (B) THEN + FAILED ( "INCORRECT VALUE FOR NEWCHAR'LAST" ); + END IF; + END; + + BEGIN + IF NOCHAR'FIRST /= CHARACTER'('Z') THEN + FAILED ( "INCORRECT VALUE FOR NOCHAR'FIRST" ); + END IF; + + IF NOCHAR'LAST /= CHARACTER'('A') THEN + FAILED ( "INCORRECT VALUE FOR NOCHAR'LAST" ); + END IF; + END; + + BEGIN + IF CHARACTER'FIRST /= ASCII.NUL THEN + FAILED ( "INCORRECT VALUE FOR CHARACTER'FIRST" ); + END IF; + + END; + + BEGIN + IF NONGRAPHIC'FIRST /= IDENT_CHAR (ASCII.NUL) THEN + FAILED ( "INCORRECT VALUE FOR NONGRAPHIC'FIRST" ); + END IF; + + IF NONGRAPHIC'LAST /= ASCII.US THEN + FAILED ( "INCORRECT VALUE FOR NONGRAPHIC'LAST" ); + END IF; + END; + + BEGIN + IF GRAPHIC'FIRST /= SPACE THEN + FAILED ( "INCORRECT VALUE FOR GRAPHIC'FIRST" ); + END IF; + + IF GRAPHIC'LAST /= ASCII.TILDE THEN + FAILED ( "INCORRECT VALUE FOR GRAPHIC'LAST" ); + END IF; + END; + + RESULT; +END C35507O; diff --git a/gcc-4.9/gcc/testsuite/ada/acats/tests/c3/c35507p.ada b/gcc-4.9/gcc/testsuite/ada/acats/tests/c3/c35507p.ada new file mode 100644 index 000000000..85c8c2781 --- /dev/null +++ b/gcc-4.9/gcc/testsuite/ada/acats/tests/c3/c35507p.ada @@ -0,0 +1,94 @@ +-- C35507P.ADA + +-- Grant of Unlimited Rights +-- +-- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687, +-- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained +-- unlimited rights in the software and documentation contained herein. +-- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making +-- this public release, the Government intends to confer upon all +-- recipients unlimited rights equal to those held by the Government. +-- These rights include rights to use, duplicate, release or disclose the +-- released technical data and computer software in whole or in part, in +-- any manner and for any purpose whatsoever, and to have or permit others +-- to do so. +-- +-- DISCLAIMER +-- +-- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR +-- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED +-- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF 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 ATTRIBUTES 'FIRST' AND 'LAST' YIELD THE CORRECT +-- RESULTS WHEN THE PREFIX IS A FORMAL DISCRETE TYPE WHOSE ACTUAL +-- PARAMETER IS A CHARACTER TYPE. + +-- RJW 6/03/86 +-- PWN 11/30/94 REMOVED TESTS BASED ON 128 CHARACTERS FOR ADA 9X. + +WITH REPORT; USE REPORT; + +PROCEDURE C35507P IS + + TYPE CHAR IS ('A', B); + + TYPE NEWCHAR IS NEW CHAR; + + SPACE : CONSTANT CHARACTER := ' '; + + SUBTYPE GRAPHIC IS CHARACTER RANGE SPACE .. ASCII.TILDE; + SUBTYPE NONGRAPHIC IS CHARACTER RANGE ASCII.NUL .. ASCII.US; +BEGIN + + TEST( "C35507P" , "CHECK THAT THE ATTRIBUTES 'FIRST' AND " & + "'LAST' YIELD THE CORRECT RESULTS WHEN THE " & + "PREFIX IS A FORMAL DISCRETE TYPE WHOSE " & + "ACTUAL PARAMETER IS A CHARACTER TYPE" ); + + DECLARE + GENERIC + TYPE CHTYPE IS (<>); + STR : STRING; + F, L : CHTYPE; + PROCEDURE P; + + PROCEDURE P IS + SUBTYPE NOCHAR IS CHTYPE RANGE L .. F; + BEGIN + IF CHTYPE'FIRST /= F THEN + FAILED ( "INCORRECT VALUE FOR " & STR & "'FIRST" ); + END IF; + + IF CHTYPE'LAST /= L THEN + FAILED ( "INCORRECT VALUE FOR " & STR & "'LAST" ); + END IF; + + IF NOCHAR'FIRST /= L THEN + FAILED ( "INCORRECT VALUE FOR NOCHAR'FIRST AS A " & + "SUBTYPE OF " & STR ); + END IF; + + IF NOCHAR'LAST /= F THEN + FAILED ( "INCORRECT VALUE FOR NOCHAR'LAST AS A " & + "SUBTYPE OF " & STR ); + END IF; + END P; + + PROCEDURE P1 IS NEW P (CHAR, "CHAR", 'A', B); + PROCEDURE P2 IS NEW P (NEWCHAR, "NEWCHAR", 'A', B); + PROCEDURE P3 IS NEW P + (GRAPHIC, "GRAPHIC", SPACE, ASCII.TILDE); + PROCEDURE P4 IS NEW P + (NONGRAPHIC, "NONGRAPHIC", ASCII.NUL, ASCII.US); + BEGIN + P1; + P2; + P3; + P4; + END; + + RESULT; +END C35507P; diff --git a/gcc-4.9/gcc/testsuite/ada/acats/tests/c3/c35508a.ada b/gcc-4.9/gcc/testsuite/ada/acats/tests/c3/c35508a.ada new file mode 100644 index 000000000..5e4f72da9 --- /dev/null +++ b/gcc-4.9/gcc/testsuite/ada/acats/tests/c3/c35508a.ada @@ -0,0 +1,74 @@ +-- C35508A.ADA + +-- Grant of Unlimited Rights +-- +-- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687, +-- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained +-- unlimited rights in the software and documentation contained herein. +-- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making +-- this public release, the Government intends to confer upon all +-- recipients unlimited rights equal to those held by the Government. +-- These rights include rights to use, duplicate, release or disclose the +-- released technical data and computer software in whole or in part, in +-- any manner and for any purpose whatsoever, and to have or permit others +-- to do so. +-- +-- DISCLAIMER +-- +-- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR +-- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED +-- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF 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 ATTRIBUTE 'WIDTH' YIELDS THE CORRECT RESULTS WHEN +-- THE PREFIX IS A BOOLEAN TYPE. + +-- RJW 3/14/86 COMPLETELY REVISED. + +WITH REPORT; USE REPORT; + +PROCEDURE C35508A IS + +BEGIN + + TEST( "C35508A" , "CHECK THAT THE ATTRIBUTE 'WIDTH' YIELDS " & + "THE CORRECT RESULTS WHEN THE PREFIX IS A " & + "BOOLEAN TYPE" ); + + DECLARE + TYPE NEWBOOL IS NEW BOOLEAN; + SUBTYPE FRANGE IS BOOLEAN + RANGE IDENT_BOOL(FALSE) .. IDENT_BOOL(FALSE); + SUBTYPE TRANGE IS BOOLEAN + RANGE IDENT_BOOL(TRUE) .. IDENT_BOOL(TRUE); + SUBTYPE NOBOOL IS BOOLEAN + RANGE IDENT_BOOL(TRUE) .. IDENT_BOOL(FALSE); + + BEGIN + + IF BOOLEAN'WIDTH /= 5 THEN + FAILED( "INCORRECT WIDTH FOR BOOLEAN" ); + END IF; + + IF NEWBOOL'WIDTH /= 5 THEN + FAILED( "INCORRECT WIDTH FOR NEWBOOL" ); + END IF; + + IF FRANGE'WIDTH /= 5 THEN + FAILED( "INCORRECT WIDTH FOR FRANGE" ); + END IF; + + IF TRANGE'WIDTH /= 4 THEN + FAILED( "INCORRECT WIDTH FOR TRANGE" ); + END IF; + + IF NOBOOL'WIDTH /= 0 THEN + FAILED( "INCORRECT WIDTH FOR NOBOOL" ); + END IF; + + END; + + RESULT; +END C35508A; diff --git a/gcc-4.9/gcc/testsuite/ada/acats/tests/c3/c35508b.ada b/gcc-4.9/gcc/testsuite/ada/acats/tests/c3/c35508b.ada new file mode 100644 index 000000000..b0339faec --- /dev/null +++ b/gcc-4.9/gcc/testsuite/ada/acats/tests/c3/c35508b.ada @@ -0,0 +1,79 @@ +-- C35508B.ADA + +-- Grant of Unlimited Rights +-- +-- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687, +-- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained +-- unlimited rights in the software and documentation contained herein. +-- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making +-- this public release, the Government intends to confer upon all +-- recipients unlimited rights equal to those held by the Government. +-- These rights include rights to use, duplicate, release or disclose the +-- released technical data and computer software in whole or in part, in +-- any manner and for any purpose whatsoever, and to have or permit others +-- to do so. +-- +-- DISCLAIMER +-- +-- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR +-- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED +-- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF 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 ATTRIBUTE 'WIDTH' YIELDS THE CORRECT RESULTS WHEN +-- THE PREFIX IS A GENERIC FORMAL DISCRETE TYPE WHOSE ACTUAL +-- PARAMETER IS A BOOLEAN TYPE. + +-- RJW 3/19/86 COMPLETELY REVISED. + +WITH REPORT; USE REPORT; + +PROCEDURE C35508B IS + +BEGIN + + TEST( "C35508B" , "CHECK THAT THE ATTRIBUTE 'WIDTH' YIELDS " & + "THE CORRECT RESULTS WHEN THE PREFIX IS A " & + "GENERIC FORMAL DISCRETE TYPE WHOSE ACTUAL " & + "PARAMETER IS A BOOLEAN TYPE" ); + + DECLARE + SUBTYPE FRANGE IS BOOLEAN + RANGE IDENT_BOOL(FALSE) .. IDENT_BOOL(FALSE); + SUBTYPE TRANGE IS BOOLEAN + RANGE IDENT_BOOL(TRUE) .. IDENT_BOOL(TRUE); + TYPE NEWBOOL IS NEW BOOLEAN; + + GENERIC + TYPE B IS (<>); + W : INTEGER; + PROCEDURE P (STR : STRING); + + PROCEDURE P (STR : STRING) IS + SUBTYPE NOBOOL IS B RANGE + B'VAL (IDENT_INT(1)) .. B'VAL (IDENT_INT(0)); + BEGIN + IF B'WIDTH /= W THEN + FAILED ( "INCORRECT B'WIDTH FOR " & STR ); + END IF; + IF NOBOOL'WIDTH /= 0 THEN + FAILED ( "INCORRECT NOBOOL'WIDTH FOR " & STR ); + END IF; + END P; + + PROCEDURE PROC1 IS NEW P (BOOLEAN, 5); + PROCEDURE PROC2 IS NEW P (FRANGE, 5); + PROCEDURE PROC3 IS NEW P (TRANGE, 4); + PROCEDURE PROC4 IS NEW P (NEWBOOL, 5); + + BEGIN + PROC1 ( "BOOLEAN" ); + PROC2 ( "FRANGE" ); + PROC3 ( "TRANGE"); + PROC4 ( "NEWBOOL" ); + END; + + RESULT; +END C35508B; diff --git a/gcc-4.9/gcc/testsuite/ada/acats/tests/c3/c35508c.ada b/gcc-4.9/gcc/testsuite/ada/acats/tests/c3/c35508c.ada new file mode 100644 index 000000000..88ca20ad2 --- /dev/null +++ b/gcc-4.9/gcc/testsuite/ada/acats/tests/c3/c35508c.ada @@ -0,0 +1,195 @@ +-- C35508C.ADA + +-- Grant of Unlimited Rights +-- +-- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687, +-- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained +-- unlimited rights in the software and documentation contained herein. +-- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making +-- this public release, the Government intends to confer upon all +-- recipients unlimited rights equal to those held by the Government. +-- These rights include rights to use, duplicate, release or disclose the +-- released technical data and computer software in whole or in part, in +-- any manner and for any purpose whatsoever, and to have or permit others +-- to do so. +-- +-- DISCLAIMER +-- +-- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR +-- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED +-- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF 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 ATTRIBUTES 'IMAGE' AND 'VALUE' YIELD THE CORRECT +-- RESULTS WHEN THE PREFIX IS A BOOLEAN TYPE. + +-- SUBTESTS ARE: +-- (A). TESTS FOR IMAGE. +-- (B). TESTS FOR VALUE. + +-- RJW 3/19/86 + +WITH REPORT; USE REPORT; + +PROCEDURE C35508C IS + + TYPE NEWBOOL IS NEW BOOLEAN; + +BEGIN + + TEST( "C35508C" , "CHECK THAT THE ATTRIBUTES 'IMAGE' AND " & + "'VALUE' YIELD THE CORRECT RESULTS WHEN THE " & + "PREFIX IS A BOOLEAN TYPE" ); +-- PART (A). + + DECLARE + + A5, B5 : INTEGER := IDENT_INT(5); + C6 : INTEGER := IDENT_INT(6); + BEGIN + + IF BOOLEAN'IMAGE ( A5 = B5 ) /= "TRUE" THEN + FAILED ( "INCORRECT IMAGE FOR 'A5 = B5'" ); + END IF; + IF BOOLEAN'IMAGE ( A5 = B5 )'FIRST /= 1 THEN + FAILED ( "INCORRECT LOWER BOUND FOR 'A5 = B5'" ); + END IF; + + IF BOOLEAN'IMAGE ( C6 = A5 ) /= "FALSE" THEN + FAILED ( "INCORRECT IMAGE FOR 'C6 = A5'" ); + END IF; + IF BOOLEAN'IMAGE ( C6 = A5 )'FIRST /= 1 THEN + FAILED ( "INCORRECT LOWER BOUND FOR 'C6 = A5'" ); + END IF; + + IF BOOLEAN'IMAGE (TRUE) /= "TRUE" THEN + FAILED ( "INCORRECT IMAGE FOR 'TRUE'" ); + END IF; + IF BOOLEAN'IMAGE (TRUE)'FIRST /= 1 THEN + FAILED ( "INCORRECT LOWER BOUND FOR 'TRUE'" ); + END IF; + + IF NEWBOOL'IMAGE (FALSE) /= "FALSE" THEN + FAILED ( "INCORRECT IMAGE FOR NEWBOOL'FALSE'" ); + END IF; + IF NEWBOOL'IMAGE (FALSE)'FIRST /= 1 THEN + FAILED ( "INCORRECT LOWER BOUND FOR NEWBOOL'FALSE'" ); + END IF; + END; + +----------------------------------------------------------------------- + +-- PART (B). + + BEGIN + IF BOOLEAN'VALUE (IDENT_STR("TRUE")) /= TRUE THEN + FAILED ( "INCORRECT VALUE FOR ""TRUE""" ); + END IF; + EXCEPTION + WHEN OTHERS => + FAILED ( "EXCEPTION RAISED - VALUE FOR ""TRUE""" ); + END; + + BEGIN + IF NEWBOOL'VALUE (IDENT_STR("FALSE")) /= FALSE THEN + FAILED ( "INCORRECT VALUE FOR ""FALSE""" ); + END IF; + EXCEPTION + WHEN OTHERS => + FAILED ( "EXCEPTION RAISED - VALUE FOR ""FALSE""" ); + END; + + BEGIN + IF BOOLEAN'VALUE ("true") /= TRUE THEN + FAILED ( "INCORRECT VALUE FOR ""true""" ); + END IF; + EXCEPTION + WHEN OTHERS => + FAILED ( "EXCEPTION RAISED - VALUE FOR ""true""" ); + END; + + BEGIN + IF NEWBOOL'VALUE ("false") /= FALSE THEN + FAILED ( "INCORRECT VALUE FOR ""false""" ); + END IF; + EXCEPTION + WHEN OTHERS => + FAILED ( "EXCEPTION RAISED - VALUE FOR " & + """false""" ); + END; + + BEGIN + IF BOOLEAN'VALUE (IDENT_STR("TRUE ")) /= TRUE THEN + FAILED ( "INCORRECT VALUE WITH TRAILING BLANKS" ); + END IF; + EXCEPTION + WHEN OTHERS => + FAILED ( "EXCEPTION RAISED - VALUE - " & + "TRAILING BLANKS" ); + END; + + BEGIN + IF NEWBOOL'VALUE (" FALSE") /= FALSE THEN + FAILED ( "INCORRECT VALUE WITH LEADING BLANKS" ); + END IF; + EXCEPTION + WHEN OTHERS => + FAILED ( "EXCEPTION RAISED - VALUE - LEADING " & + "BLANKS" ); + END; + + DECLARE + SUBTYPE SUBBOOL IS BOOLEAN RANGE FALSE .. FALSE; + BEGIN + IF SUBBOOL'VALUE (IDENT_STR("TRUE")) /= TRUE THEN + FAILED ( "INCORRECT VALUE - ""TRUE"" AND " & + "SUBBOOL" ); + END IF; + EXCEPTION + WHEN OTHERS => + FAILED ( "EXCEPTION RAISED - SUBBOOL" ); + END; + + BEGIN + IF BOOLEAN'VALUE (IDENT_STR("MAYBE")) = TRUE THEN + FAILED ( "NO EXCEPTION RAISED - ""MAYBE"" - 1" ); + ELSE + FAILED ( "NO EXCEPTION RAISED - ""MAYBE"" - 2" ); + END IF; + EXCEPTION + WHEN CONSTRAINT_ERROR => + NULL; + WHEN OTHERS => + FAILED ( "WRONG EXCEPTION RAISED - ""MAYBE"" " ); + END; + + BEGIN + IF BOOLEAN'VALUE (IDENT_CHAR(ASCII.HT) & "TRUE") = TRUE THEN + FAILED ( "NO EXCEPTION RAISED - LEADING 'HT' - 1" ); + ELSE + FAILED ( "NO EXCEPTION RAISED - LEADING 'HT' - 2" ); + END IF; + EXCEPTION + WHEN CONSTRAINT_ERROR => + NULL; + WHEN OTHERS => + FAILED ( "WRONG EXCEPTION RAISED - LEADING 'HT'" ); + END; + + BEGIN + IF NEWBOOL'VALUE ("FALSE" & ASCII.HT) = FALSE THEN + FAILED ( "NO EXCEPTION RAISED - TRAILING 'HT' - 1" ); + ELSE + FAILED ( "NO EXCEPTION RAISED - TRAILING 'HT' - 2" ); + END IF; + EXCEPTION + WHEN CONSTRAINT_ERROR => + NULL; + WHEN OTHERS => + FAILED ( "WRONG EXCEPTION RAISED - TRAILING 'HT'" ); + END; + + RESULT; +END C35508C; diff --git a/gcc-4.9/gcc/testsuite/ada/acats/tests/c3/c35508e.ada b/gcc-4.9/gcc/testsuite/ada/acats/tests/c3/c35508e.ada new file mode 100644 index 000000000..584ccfec8 --- /dev/null +++ b/gcc-4.9/gcc/testsuite/ada/acats/tests/c3/c35508e.ada @@ -0,0 +1,192 @@ +-- C35508E.ADA + +-- Grant of Unlimited Rights +-- +-- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687, +-- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained +-- unlimited rights in the software and documentation contained herein. +-- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making +-- this public release, the Government intends to confer upon all +-- recipients unlimited rights equal to those held by the Government. +-- These rights include rights to use, duplicate, release or disclose the +-- released technical data and computer software in whole or in part, in +-- any manner and for any purpose whatsoever, and to have or permit others +-- to do so. +-- +-- DISCLAIMER +-- +-- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR +-- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED +-- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF 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 ATTRIBUTES 'IMAGE' AND 'VALUE' YIELD THE CORRECT +-- RESULTS WHEN THE PREFIX IS A GENERIC FORMAL DISCRETE TYPE WHOSE +-- ACTUAL ARGUMENT IS A BOOLEAN TYPE. + +-- SUBTESTS ARE: +-- (A). TESTS FOR IMAGE. +-- (B). TESTS FOR VALUE. + +-- HISTORY: +-- RJW 03/19/86 CREATED ORIGINAL TEST. +-- DHH 10/19/87 SHORTENED LINES CONTAINING MORE THAN 72 CHARACTERS. + +WITH REPORT; USE REPORT; + +PROCEDURE C35508E IS + +BEGIN + + TEST( "C35508E" , "CHECK THAT THE ATTRIBUTES 'IMAGE' AND " & + "'VALUE' YIELD THE CORRECT RESULTS WHEN THE " & + "PREFIX IS A GENERIC FORMAL DISCRETE TYPE " & + "WHOSE ACTUAL ARGUMENT IS A BOOLEAN TYPE" ); +-- PART (A). + + DECLARE + TYPE NEWBOOL IS NEW BOOLEAN; + + GENERIC + TYPE BOOL IS (<>); + PROCEDURE P (B : BOOL; STR : STRING ); + + PROCEDURE P (B : BOOL; STR : STRING) IS + SUBTYPE SUBBOOL IS BOOL + RANGE BOOL'VAL (IDENT_INT(0)) .. + BOOL'VAL (IDENT_INT(0)); + BEGIN + + IF BOOL'IMAGE (B) /= STR THEN + FAILED ( "INCORRECT BOOL'IMAGE OF " & STR ); + END IF; + IF BOOL'IMAGE (B)'FIRST /= 1 THEN + FAILED ( "INCORRECT BOOL'FIRST FOR " & STR ); + END IF; + + IF SUBBOOL'IMAGE (B) /= STR THEN + FAILED ( "INCORRECT SUBBOOL'IMAGE OF " & STR ); + END IF; + IF SUBBOOL'IMAGE (B)'FIRST /= 1 THEN + FAILED ( "INCORRECT SUBBOOL'FIRST FOR " & STR ); + END IF; + END P; + + PROCEDURE NP1 IS NEW P ( BOOLEAN ); + PROCEDURE NP2 IS NEW P ( NEWBOOL ); + BEGIN + NP1 ( TRUE, "TRUE" ); + NP2 ( FALSE, "FALSE" ); + + END; + +----------------------------------------------------------------------- + +-- PART (B). + + DECLARE + TYPE NEWBOOL IS NEW BOOLEAN; + + GENERIC + TYPE BOOL IS (<>); + PROCEDURE P (STR : STRING; B : BOOL ); + + PROCEDURE P (STR : STRING; B : BOOL) IS + SUBTYPE SUBBOOL IS BOOL + RANGE BOOL'VAL (IDENT_INT(0)) .. + BOOL'VAL (IDENT_INT(0)); + + BEGIN + BEGIN + IF BOOL'VALUE (STR) /= B THEN + FAILED ( "INCORRECT BOOL'VALUE OF """ & + STR & """" ); + END IF; + EXCEPTION + WHEN OTHERS => + FAILED ( "EXCEPTION RAISED BOOL'VALUE OF """ & + STR & """" ); + END; + BEGIN + IF SUBBOOL'VALUE (STR) /= B THEN + FAILED ( "INCORRECT SUBBOOL'VALUE OF """ & + STR & """" ); + END IF; + EXCEPTION + WHEN OTHERS => + FAILED ( "EXCEPTION RAISED SUBBOOL'VALUE " & + "OF """ & STR & """" ); + END; + END P; + + PROCEDURE NP1 IS NEW P ( BOOLEAN ); + PROCEDURE NP2 IS NEW P ( NEWBOOL ); + + BEGIN + NP1 ( "TRUE", TRUE ); + NP2 ( "FALSE", FALSE ); + NP2 ( "true", TRUE ); + NP1 ( "false", FALSE ); + NP1 ( " TRUE", TRUE ); + NP2 ( "FALSE ", FALSE ); + END; + + DECLARE + GENERIC + TYPE BOOL IS (<>); + PROCEDURE P (STR1 : STRING; B : BOOL; STR2 : STRING); + + PROCEDURE P (STR1 : STRING; B : BOOL; STR2 : STRING) IS + SUBTYPE SUBBOOL IS BOOL + RANGE BOOL'VAL (IDENT_INT(0)) .. + BOOL'VAL (IDENT_INT(0)); + + BEGIN + BEGIN + IF BOOL'VALUE (STR1) = B THEN + FAILED ( "NO EXCEPTION RAISED - " & + "BOOL'VALUE WITH " & STR2 & + "- EQUAL " ); + ELSE + FAILED ( "NO EXCEPTION RAISED - " & + "BOOL'VALUE WITH " & STR2 & + " - NOT EQUAL" ); + END IF; + EXCEPTION + WHEN CONSTRAINT_ERROR => + NULL; + WHEN OTHERS => + FAILED ( "WRONG EXCEPTION RAISED - " & + "BOOL'VALUE WITH " & STR2 ); + END; + BEGIN + IF SUBBOOL'VALUE (STR1) /= B THEN + FAILED ( "NO EXCEPTION RAISED - " & + "SUBBOOL'VALUE WITH " & + STR2 & " - EQUAL"); + ELSE + FAILED ( "NO EXCEPTION RAISED - " & + "SUBBOOL'VALUE WITH " & + STR2 & " - NOT EQUAL"); + END IF; + EXCEPTION + WHEN CONSTRAINT_ERROR => + NULL; + WHEN OTHERS => + FAILED ( "WRONG EXCEPTION RAISED - " & + "SUBBOOL'VALUE WITH " & STR2 ); + END; + END P; + + PROCEDURE NP IS NEW P ( BOOLEAN ); + BEGIN + NP ( "MAYBE", TRUE, "NON-BOOLEAN VALUE"); + NP ( ASCII.HT & "TRUE", TRUE, "LEADING 'HT'" ); + NP ( "FALSE" & ASCII.HT , FALSE, "TRAILING 'HT'" ); + END; + + RESULT; +END C35508E; diff --git a/gcc-4.9/gcc/testsuite/ada/acats/tests/c3/c35508g.ada b/gcc-4.9/gcc/testsuite/ada/acats/tests/c3/c35508g.ada new file mode 100644 index 000000000..dd546d2b9 --- /dev/null +++ b/gcc-4.9/gcc/testsuite/ada/acats/tests/c3/c35508g.ada @@ -0,0 +1,105 @@ +-- C35508G.ADA + +-- Grant of Unlimited Rights +-- +-- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687, +-- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained +-- unlimited rights in the software and documentation contained herein. +-- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making +-- this public release, the Government intends to confer upon all +-- recipients unlimited rights equal to those held by the Government. +-- These rights include rights to use, duplicate, release or disclose the +-- released technical data and computer software in whole or in part, in +-- any manner and for any purpose whatsoever, and to have or permit others +-- to do so. +-- +-- DISCLAIMER +-- +-- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR +-- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED +-- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF 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 'PRED' AND 'SUCC' YIELD THE CORRECT RESULTS WHEN THE +-- PREFIX IS A BOOLEAN TYPE. + +-- HISTORY: +-- RJW 03/19/86 CREATED ORIGINAL TEST. +-- DHH 10/19/87 SHORTENED LINES CONTAINING MORE THAN 72 CHARACTERS. + +WITH REPORT; USE REPORT; + +PROCEDURE C35508G IS + +BEGIN + TEST ("C35508G", "CHECK THAT 'PRED' AND 'SUCC' YIELD THE " & + "CORRECT RESULTS WHEN THE PREFIX IS A " & + "BOOLEAN TYPE" ); + + BEGIN + IF BOOLEAN'PRED (IDENT_BOOL(TRUE)) /= FALSE THEN + FAILED ( "INCORRECT VALUE FOR PRED OF TRUE" ); + END IF; + IF BOOLEAN'SUCC (IDENT_BOOL(FALSE)) /= TRUE THEN + FAILED ( "INCORRECT VALUE FOR SUCC OF FALSE" ); + END IF; + END; + + DECLARE + TYPE NEWBOOL IS NEW BOOLEAN; + BEGIN + IF NEWBOOL'PRED (TRUE) /= FALSE THEN + FAILED ( "INCORRECT VALUE FOR NEWBOOL'PRED OF TRUE" ); + END IF; + IF NEWBOOL'SUCC (FALSE) /= TRUE THEN + FAILED ( "INCORRECT VALUE FOR NEWBOOL'SUCC OF FALSE" ); + END IF; + END; + + DECLARE + + SUBTYPE SBOOL IS BOOLEAN RANGE IDENT_BOOL(TRUE) .. + IDENT_BOOL(TRUE); + + BEGIN + BEGIN + IF SBOOL'PRED (IDENT_BOOL(TRUE)) /= FALSE THEN + FAILED ( "INCORRECT VALUE FOR SBOOL'PRED " & + "OF TRUE" ); + END IF; + END; + + BEGIN + IF SBOOL'PRED (IDENT_BOOL(SBOOL'BASE'FIRST)) = TRUE THEN + FAILED("'PRED('FIRST) WRAPPED AROUNT TO TRUE"); + END IF; + FAILED ( "NO EXCEPTION RAISED FOR " & + "'PRED (SBOOL'BASE'FIRST)" ); + EXCEPTION + WHEN CONSTRAINT_ERROR => + NULL; + WHEN OTHERS => + FAILED ( "WRONG EXCEPTION RAISED FOR " & + "'PRED (SBOOL'BASE'FIRST)" ); + END; + + BEGIN + IF SBOOL'SUCC (IDENT_BOOL(SBOOL'BASE'LAST)) = FALSE THEN + FAILED("'SUCC('LAST) WRAPPED AROUNT TO FALSE"); + END IF; + FAILED ( "NO EXCEPTION RAISED FOR " & + "'SUCC (SBOOL'BASE'LAST)" ); + EXCEPTION + WHEN CONSTRAINT_ERROR => + NULL; + WHEN OTHERS => + FAILED ( "WRONG EXCEPTION RAISED FOR " & + "'SUCC (SBOOL'BASE'LAST)" ); + END; + END; + + RESULT; +END C35508G; diff --git a/gcc-4.9/gcc/testsuite/ada/acats/tests/c3/c35508h.ada b/gcc-4.9/gcc/testsuite/ada/acats/tests/c3/c35508h.ada new file mode 100644 index 000000000..2b89a29ed --- /dev/null +++ b/gcc-4.9/gcc/testsuite/ada/acats/tests/c3/c35508h.ada @@ -0,0 +1,116 @@ +-- C35508H.ADA + +-- Grant of Unlimited Rights +-- +-- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687, +-- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained +-- unlimited rights in the software and documentation contained herein. +-- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making +-- this public release, the Government intends to confer upon all +-- recipients unlimited rights equal to those held by the Government. +-- These rights include rights to use, duplicate, release or disclose the +-- released technical data and computer software in whole or in part, in +-- any manner and for any purpose whatsoever, and to have or permit others +-- to do so. +-- +-- DISCLAIMER +-- +-- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR +-- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED +-- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF 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 'PRED' AND 'SUCC' YIELD THE CORRECT RESULTS WHEN THE +-- PREFIX IS A FORMAL DISCRETE TYPE WHOSE ACTUAL PARAMETER IS A +-- BOOLEAN TYPE. + +-- HISTORY: +-- RJW 03/24/86 CREATED ORIGINAL TEST. +-- DHH 10/19/87 SHORTENED LINES CONTAINING MORE THAN 72 CHARACTERS. + +WITH REPORT; USE REPORT; + +PROCEDURE C35508H IS + +BEGIN + TEST ("C35508H", "CHECK THAT 'PRED' AND 'SUCC' YIELD THE " & + "CORRECT RESULTS WHEN THE PREFIX IS A " & + "FORMAL DISCRETE TYPE WHOSE ACTUAL PARAMETER " & + "IS A BOOLEAN TYPE" ); + + DECLARE + + TYPE NEWBOOL IS NEW BOOLEAN; + + GENERIC + TYPE BOOL IS (<>); + F, T : BOOL; + PROCEDURE P (STR : STRING); + + PROCEDURE P (STR : STRING) IS + SUBTYPE SBOOL IS BOOL RANGE T .. T; + BEGIN + BEGIN + IF BOOL'PRED (T) /= F THEN + FAILED ( "INCORRECT VALUE FOR " & + STR & "'PRED OF T" ); + END IF; + IF BOOL'SUCC (F) /= T THEN + FAILED ( "INCORRECT VALUE FOR " & + STR & "'SUCC OF F" ); + END IF; + END; + + BEGIN + IF SBOOL'PRED (T) /= F THEN + FAILED ( "INCORRECT VALUE FOR SBOOL'PRED " & + "OF T FOR " & STR); + END IF; + END; + + BEGIN + IF SBOOL'PRED (SBOOL'BASE'FIRST) = T THEN + FAILED("'PRED('FIRST) WRAPPED AROUND " & + "TO TRUE FOR " & STR); + END IF; + FAILED ( "NO EXCEPTION RAISED FOR " & + STR & "'PRED (SBOOL'BASE'FIRST)" ); + EXCEPTION + WHEN CONSTRAINT_ERROR => + NULL; + WHEN OTHERS => + FAILED ( "WRONG EXCEPTION RAISED FOR " & + STR & "'PRED (SBOOL'BASE'FIRST)" ); + END; + + BEGIN + IF SBOOL'SUCC (SBOOL'BASE'LAST) = F THEN + FAILED("'SUCC('LAST) WRAPPED AROUND TO " & + "FALSE FOR " & STR); + END IF; + FAILED ( "NO EXCEPTION RAISED FOR " & STR & + "'SUCC (SBOOL'BASE'LAST)" ); + EXCEPTION + WHEN CONSTRAINT_ERROR => + NULL; + WHEN OTHERS => + FAILED ( "WRONG EXCEPTION RAISED FOR " & + STR & "'SUCC (SBOOL'BASE'LAST)" ); + END; + END P; + + PROCEDURE NP1 IS NEW P + ( BOOL => BOOLEAN, F => FALSE, T => TRUE ); + + PROCEDURE NP2 IS NEW P + ( BOOL => NEWBOOL, F => FALSE, T => TRUE ); + BEGIN + NP1 ("BOOLEAN"); + NP2 ("NEWBOOL"); + END; + + RESULT; +END C35508H; diff --git a/gcc-4.9/gcc/testsuite/ada/acats/tests/c3/c35508k.ada b/gcc-4.9/gcc/testsuite/ada/acats/tests/c3/c35508k.ada new file mode 100644 index 000000000..338397a5b --- /dev/null +++ b/gcc-4.9/gcc/testsuite/ada/acats/tests/c3/c35508k.ada @@ -0,0 +1,125 @@ +-- C35508K.ADA + +-- Grant of Unlimited Rights +-- +-- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687, +-- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained +-- unlimited rights in the software and documentation contained herein. +-- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making +-- this public release, the Government intends to confer upon all +-- recipients unlimited rights equal to those held by the Government. +-- These rights include rights to use, duplicate, release or disclose the +-- released technical data and computer software in whole or in part, in +-- any manner and for any purpose whatsoever, and to have or permit others +-- to do so. +-- +-- DISCLAIMER +-- +-- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR +-- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED +-- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF 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 'POS' AND 'VAL' YIELD THE CORRECT RESULTS WHEN THE +-- PREFIX IS A BOOLEAN TYPE. + +-- RJW 3/19/86 +-- PWN 01/31/95 REMOVED INCONSISTENCIES WITH ADA 9X. + +WITH REPORT; USE REPORT; + +PROCEDURE C35508K IS + + TYPE NEWBOOL IS NEW BOOLEAN; + +BEGIN + TEST ("C35508K", "CHECK THAT 'POS' AND 'VAL' YIELD THE " & + "CORRECT RESULTS WHEN THE PREFIX IS A " & + "BOOLEAN TYPE" ); + + BEGIN + IF BOOLEAN'POS (IDENT_BOOL(FALSE)) /= 0 THEN + FAILED ( "WRONG POS FOR 'FALSE'" ); + END IF; + IF BOOLEAN'POS (IDENT_BOOL(TRUE)) /= 1 THEN + FAILED ( "WRONG POS FOR 'TRUE'" ); + END IF; + + IF BOOLEAN'VAL (IDENT_INT(0)) /= FALSE THEN + FAILED ( "WRONG VAL FOR '0'" ); + END IF; + IF BOOLEAN'VAL (IDENT_INT(1)) /= TRUE THEN + FAILED ( "WRONG VAL FOR '1'" ); + END IF; + END; + + BEGIN + IF BOOLEAN'VAL (IDENT_INT(-1)) = TRUE THEN + FAILED("'VAL(-1) WRAPPED AROUND TO TRUE"); + END IF; + FAILED ( "NO EXCEPTION RAISED FOR VAL OF '-1'" ); + EXCEPTION + WHEN CONSTRAINT_ERROR => + NULL; + WHEN OTHERS => + FAILED ( "WRONG EXCEPTION RAISED FOR VAL OF '-1'" ); + END; + + BEGIN + IF BOOLEAN'VAL (IDENT_INT(2)) = FALSE THEN + FAILED("BOOLEAN'VAL(2) WRAPPED AROUND TO FALSE"); + END IF; + FAILED ( "NO EXCEPTION RAISED FOR VAL OF '2'" ); + EXCEPTION + WHEN CONSTRAINT_ERROR => + NULL; + WHEN OTHERS => + FAILED ( "WRONG EXCEPTION RAISED FOR VAL OF '2'" ); + END; + + BEGIN + IF NEWBOOL'POS (FALSE) /= 0 THEN + FAILED ( "WRONG POS FOR NEWBOOL'(FALSE)" ); + END IF; + IF NEWBOOL'POS (TRUE) /= 1 THEN + FAILED ( "WRONG POS FOR NEWBOOL'(TRUE)" ); + END IF; + + IF NEWBOOL'VAL (0) /= FALSE THEN + FAILED ( "WRONG NEWBOOL'VAL FOR '0'" ); + END IF; + IF NEWBOOL'VAL (1) /= TRUE THEN + FAILED ( "WRONG NEWBOOL'VAL FOR '1'" ); + END IF; + END; + + BEGIN + IF NEWBOOL'VAL (IDENT_INT(-1)) = TRUE THEN + FAILED("NEWBOOL'VAL(-1) WRAPPED AROUND TO TRUE"); + END IF; + FAILED ( "NO EXCEPTION RAISED FOR NEWBOOL'VAL OF '-1'" ); + EXCEPTION + WHEN CONSTRAINT_ERROR => + NULL; + WHEN OTHERS => + FAILED ( "WRONG EXCEPTION RAISED FOR " & + "NEWBOOL'VAL OF '-1'" ); + END; + + BEGIN + IF NEWBOOL'VAL (IDENT_INT(2)) = FALSE THEN + FAILED("NEWBOOL'VAL(2) WRAPPED AROUND TO FALSE"); + END IF; + FAILED ( "NO EXCEPTION RAISED FOR NEWBOOL'VAL OF '2'" ); + EXCEPTION + WHEN CONSTRAINT_ERROR => + NULL; + WHEN OTHERS => + FAILED ( "WRONG EXCEPTION RAISED FOR " & + "NEWBOOL'VAL OF '2'" ); + END; + + RESULT; +END C35508K; diff --git a/gcc-4.9/gcc/testsuite/ada/acats/tests/c3/c35508l.ada b/gcc-4.9/gcc/testsuite/ada/acats/tests/c3/c35508l.ada new file mode 100644 index 000000000..cba30e237 --- /dev/null +++ b/gcc-4.9/gcc/testsuite/ada/acats/tests/c3/c35508l.ada @@ -0,0 +1,132 @@ +-- C35508L.ADA + +-- Grant of Unlimited Rights +-- +-- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687, +-- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained +-- unlimited rights in the software and documentation contained herein. +-- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making +-- this public release, the Government intends to confer upon all +-- recipients unlimited rights equal to those held by the Government. +-- These rights include rights to use, duplicate, release or disclose the +-- released technical data and computer software in whole or in part, in +-- any manner and for any purpose whatsoever, and to have or permit others +-- to do so. +-- +-- DISCLAIMER +-- +-- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR +-- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED +-- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF 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 'POS' AND 'VAL' YIELD THE CORRECT RESULTS WHEN THE +-- PREFIX IS A FORMAL DISCRETE TYPE WHOSE ACTUAL PARAMETER IS A +-- BOOLEAN TYPE. + +-- RJW 3/24/86 + +WITH REPORT; USE REPORT; + +PROCEDURE C35508L IS + +BEGIN + TEST ("C35508L", "CHECK THAT 'POS' AND 'VAL' YIELD THE " & + "CORRECT RESULTS WHEN THE PREFIX IS A " & + "FORMAL DISCRETE TYPE WHOSE ACTUAL PARAMETER " & + "IS A BOOLEAN TYPE" ); + + DECLARE + TYPE NEWBOOL IS NEW BOOLEAN; + + GENERIC + TYPE BOOL IS (<>); + PROCEDURE P (STR : STRING; B : BOOL; I : INTEGER); + + PROCEDURE P (STR : STRING; B : BOOL; I : INTEGER) IS + SUBTYPE SBOOL IS BOOL + RANGE BOOL'VAL (IDENT_INT(0)) .. BOOL'VAL (IDENT_INT(0)); + BEGIN + IF BOOL'POS (B) /= I THEN + FAILED ( "WRONG " & STR & "'POS FOR " & + BOOL'IMAGE (B) & " - 1" ); + END IF; + IF BOOL'VAL (I) /= B THEN + FAILED ( "WRONG " & STR & "'VAL FOR " & + INTEGER'IMAGE (I) & " - 1" ); + END IF; + + IF SBOOL'POS (B) /= I THEN + FAILED ( "WRONG " & STR & "'POS FOR " & + BOOL'IMAGE (B) & " - 2" ); + END IF; + + IF SBOOL'VAL (I) /= B THEN + FAILED ( "WRONG " & STR & "'VAL FOR " & + INTEGER'IMAGE (I) & " - 2" ); + END IF; + END P; + + GENERIC + TYPE BOOL IS (<>); + PROCEDURE Q (STR : STRING; B : BOOL; I : INTEGER); + + PROCEDURE Q (STR : STRING; B : BOOL; I : INTEGER) IS + SUBTYPE SBOOL IS BOOL + RANGE BOOL'VAL (IDENT_INT(0)) .. BOOL'VAL (IDENT_INT(0)); + BEGIN + BEGIN + IF BOOL'VAL (I) = B THEN + FAILED (STR & "'VAL OF " & INTEGER'IMAGE (I) & + " = " & BOOL'IMAGE (B)); + END IF; + FAILED ( "NO EXCEPTION RAISED FOR " & STR & + "'VAL OF " & INTEGER'IMAGE (I) ); + EXCEPTION + WHEN CONSTRAINT_ERROR => + NULL; + WHEN OTHERS => + FAILED ( "WRONG EXCEPTION RAISED FOR " & STR & + "'VAL " & "OF " & + INTEGER'IMAGE (I) ); + END; + + BEGIN + IF SBOOL'VAL (I) = B THEN + FAILED (STR & " SBOOL'VAL OF " & + INTEGER'IMAGE(I) & " = " & + BOOL'IMAGE (B) ); + END IF; + FAILED( "NO EXCEPTION RAISED FOR VAL OF " & + INTEGER'IMAGE (I) & + "WITH SBOOL OF " & STR); + EXCEPTION + WHEN CONSTRAINT_ERROR => + NULL; + WHEN OTHERS => + FAILED ( "WRONG EXCEPTION RAISED FOR " & STR & + "'VAL " & "OF " & + INTEGER'IMAGE (I) & + "WITH SBOOL " ); + END; + END Q; + + PROCEDURE NP1 IS NEW P ( BOOL => BOOLEAN ); + PROCEDURE NP2 IS NEW P ( BOOL => NEWBOOL ); + PROCEDURE NQ1 IS NEW Q ( BOOL => BOOLEAN ); + PROCEDURE NQ2 IS NEW Q ( BOOL => NEWBOOL ); + BEGIN + NP1 ( "BOOLEAN", IDENT_BOOL(FALSE) , IDENT_INT(0) ); + NP1 ( "BOOLEAN", IDENT_BOOL(TRUE) , IDENT_INT(1) ); + NP2 ( "NEWBOOL", FALSE , 0 ); + NP2 ( "NEWBOOL", TRUE , 1 ); + NQ1 ( "BOOLEAN", IDENT_BOOL(FALSE) , IDENT_INT(-1) ); + NQ1 ( "BOOLEAN", IDENT_BOOL(TRUE) , IDENT_INT(2) ); + NQ2 ( "NEWBOOL", FALSE , -1 ); + NQ2 ( "NEWBOOL", TRUE , 2 ); + END; + + RESULT; +END C35508L; diff --git a/gcc-4.9/gcc/testsuite/ada/acats/tests/c3/c35508o.ada b/gcc-4.9/gcc/testsuite/ada/acats/tests/c3/c35508o.ada new file mode 100644 index 000000000..ff1eb67e6 --- /dev/null +++ b/gcc-4.9/gcc/testsuite/ada/acats/tests/c3/c35508o.ada @@ -0,0 +1,98 @@ +-- C35508O.ADA + +-- Grant of Unlimited Rights +-- +-- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687, +-- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained +-- unlimited rights in the software and documentation contained herein. +-- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making +-- this public release, the Government intends to confer upon all +-- recipients unlimited rights equal to those held by the Government. +-- These rights include rights to use, duplicate, release or disclose the +-- released technical data and computer software in whole or in part, in +-- any manner and for any purpose whatsoever, and to have or permit others +-- to do so. +-- +-- DISCLAIMER +-- +-- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR +-- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED +-- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF 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 'FIRST' AND 'LAST' YIELD THE CORRECT RESULTS WHEN THE +-- PREFIX IS A BOOLEAN TYPE. + +-- HISTORY: +-- RJW 03/19/86 CREATED ORIGINAL TEST. +-- DHH 10/19/87 SHORTENED LINES CONTAINING MORE THAN 72 CHARACTERS. + +WITH REPORT; USE REPORT; + +PROCEDURE C35508O IS + +BEGIN + TEST ("C35508O", "CHECK THAT 'FIRST' AND 'LAST' YIELD THE " & + "CORRECT RESULTS WHEN THE PREFIX IS A " & + "BOOLEAN TYPE" ); + + DECLARE + SUBTYPE TBOOL IS BOOLEAN RANGE IDENT_BOOL(TRUE) .. + IDENT_BOOL(TRUE); + SUBTYPE FBOOL IS BOOLEAN + RANGE IDENT_BOOL(FALSE) .. IDENT_BOOL(FALSE); + SUBTYPE NOBOOL IS BOOLEAN + RANGE IDENT_BOOL(TRUE) .. IDENT_BOOL(FALSE); + TYPE NEWBOOL IS NEW BOOLEAN; + TYPE NIL IS NEW BOOLEAN RANGE IDENT_BOOL(TRUE) .. + IDENT_BOOL(FALSE); + + BEGIN + IF IDENT_BOOL(BOOLEAN'FIRST) /= FALSE THEN + FAILED ( "WRONG VALUE FOR BOOLEAN'FIRST" ); + END IF; + IF IDENT_BOOL(BOOLEAN'LAST) /= TRUE THEN + FAILED ( "WRONG VALUE FOR BOOLEAN'LAST" ); + END IF; + + IF TBOOL'FIRST /= TRUE THEN + FAILED ( "WRONG VALUE FOR TBOOL'FIRST" ); + END IF; + IF TBOOL'LAST /= TRUE THEN + FAILED ( "WRONG VALUE FOR TBOOL'LAST" ); + END IF; + + IF FBOOL'FIRST /= FALSE THEN + FAILED ( "WRONG VALUE FOR FBOOL'FIRST" ); + END IF; + IF FBOOL'LAST /= FALSE THEN + FAILED ( "WRONG VALUE FOR FBOOL'LAST" ); + END IF; + + IF NOBOOL'FIRST /= TRUE THEN + FAILED ( "WRONG VALUE FOR NOBOOL'FIRST" ); + END IF; + IF NOBOOL'LAST /= FALSE THEN + FAILED ( "WRONG VALUE FOR NOBOOL'LAST" ); + END IF; + + IF NEWBOOL'FIRST /= FALSE THEN + FAILED ( "WRONG VALUE FOR NEWBOOL'FIRST" ); + END IF; + IF NEWBOOL'LAST /= TRUE THEN + FAILED ( "WRONG VALUE FOR NEWBOOL'LAST" ); + END IF; + IF NIL'FIRST /= TRUE THEN + FAILED ( "WRONG VALUE FOR NIL'FIRST" ); + END IF; + IF NIL'LAST /= FALSE THEN + FAILED ( "WRONG VALUE FOR NIL'LAST" ); + END IF; + + END; + + RESULT; +END C35508O; diff --git a/gcc-4.9/gcc/testsuite/ada/acats/tests/c3/c35508p.ada b/gcc-4.9/gcc/testsuite/ada/acats/tests/c3/c35508p.ada new file mode 100644 index 000000000..8ee3e8848 --- /dev/null +++ b/gcc-4.9/gcc/testsuite/ada/acats/tests/c3/c35508p.ada @@ -0,0 +1,131 @@ +-- C35508P.ADA + +-- Grant of Unlimited Rights +-- +-- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687, +-- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained +-- unlimited rights in the software and documentation contained herein. +-- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making +-- this public release, the Government intends to confer upon all +-- recipients unlimited rights equal to those held by the Government. +-- These rights include rights to use, duplicate, release or disclose the +-- released technical data and computer software in whole or in part, in +-- any manner and for any purpose whatsoever, and to have or permit others +-- to do so. +-- +-- DISCLAIMER +-- +-- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR +-- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED +-- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF 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 'FIRST' AND 'LAST' YIELD THE CORRECT RESULTS WHEN THE +-- PREFIX IS A GENERIC FORMAL DISCRETE TYPE WHOSE ACTUAL PARAMETER +-- IS A BOOLEAN TYPE. + +-- HISTORY: +-- RJW 03/19/86 CREATED ORIGINAL TEST. +-- DHH 10/19/87 SHORTENED LINES CONTAINING MORE THAN 72 CHARACTERS. + +WITH REPORT; USE REPORT; + +PROCEDURE C35508P IS + +BEGIN + TEST ("C35508P", "CHECK THAT 'FIRST' AND 'LAST' YIELD THE " & + "CORRECT RESULTS WHEN THE PREFIX IS A " & + "GENERIC FORMAL DISCRETE TYPE WHOSE ACTUAL " & + "PARAMETER IS A BOOLEAN TYPE" ); + DECLARE + SUBTYPE TBOOL IS BOOLEAN + RANGE IDENT_BOOL(TRUE) .. IDENT_BOOL(TRUE); + SUBTYPE FBOOL IS BOOLEAN + RANGE IDENT_BOOL(FALSE) .. IDENT_BOOL(FALSE); + SUBTYPE NOBOOL IS BOOLEAN + RANGE IDENT_BOOL(TRUE) .. IDENT_BOOL(FALSE); + TYPE NEWBOOL IS NEW BOOLEAN; + + GENERIC + TYPE BOOL IS (<>); + F, L : BOOL; + PROCEDURE P ( STR : STRING ); + + PROCEDURE P ( STR : STRING ) IS + BEGIN + IF BOOL'FIRST /= F THEN + FAILED ( "WRONG VALUE FOR " & STR & "'FIRST" ); + END IF; + IF BOOL'LAST /= L THEN + FAILED ( "WRONG VALUE FOR " & STR & "'LAST" ); + END IF; + END P; + + GENERIC + TYPE BOOL IS (<>); + PROCEDURE Q; + + PROCEDURE Q IS + BEGIN + IF BOOL'FIRST /= BOOL'VAL (IDENT_INT(1)) THEN + FAILED ( "WRONG 'FIRST FOR NOBOOL" ); + END IF; + IF BOOL'LAST /= BOOL'VAL (IDENT_INT(0)) THEN + FAILED ( "WRONG 'LAST FOR NOBOOL" ); + END IF; + END Q; + + GENERIC + TYPE BOOL IS (<>); + F, L : BOOL; + PROCEDURE R; + + PROCEDURE R IS + SUBTYPE SBOOL IS BOOL + RANGE BOOL'VAL (0) .. BOOL'VAL (1); + BEGIN + IF SBOOL'FIRST /= F THEN + FAILED ( "WRONG VALUE FOR BOOLEAN'FIRST AS " & + "SUBTYPE " ); + END IF; + IF SBOOL'LAST /= L THEN + FAILED ( "WRONG VALUE FOR BOOLEAN'LAST AS " & + "SUBTYPE" ); + END IF; + END R; + + PROCEDURE P1 IS NEW P + ( BOOL => BOOLEAN, F => IDENT_BOOL(FALSE), + L => IDENT_BOOL(TRUE) ); + + PROCEDURE P2 IS NEW P + ( BOOL => TBOOL, F => IDENT_BOOL(TRUE), + L => IDENT_BOOL(TRUE) ); + + PROCEDURE P3 IS NEW P + ( BOOL => FBOOL, F => IDENT_BOOL(FALSE), + L => IDENT_BOOL(FALSE) ); + + PROCEDURE P4 IS NEW P + (BOOL => NEWBOOL, F => FALSE, L => TRUE ); + + PROCEDURE Q1 IS NEW Q + ( BOOL => NOBOOL ); + + PROCEDURE R1 IS NEW R + ( BOOL => BOOLEAN, F => FALSE, L => TRUE ); + + BEGIN + P1 ( "BOOLEAN" ); + P2 ( "TBOOL" ); + P3 ( "FBOOL" ); + P4 ( "NEWBOOL" ); + Q1; + R1; + END; + + RESULT; +END C35508P; diff --git a/gcc-4.9/gcc/testsuite/ada/acats/tests/c3/c35703a.ada b/gcc-4.9/gcc/testsuite/ada/acats/tests/c3/c35703a.ada new file mode 100644 index 000000000..6980f3c9f --- /dev/null +++ b/gcc-4.9/gcc/testsuite/ada/acats/tests/c3/c35703a.ada @@ -0,0 +1,142 @@ +-- C35703A.ADA + +-- Grant of Unlimited Rights +-- +-- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687, +-- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained +-- unlimited rights in the software and documentation contained herein. +-- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making +-- this public release, the Government intends to confer upon all +-- recipients unlimited rights equal to those held by the Government. +-- These rights include rights to use, duplicate, release or disclose the +-- released technical data and computer software in whole or in part, in +-- any manner and for any purpose whatsoever, and to have or permit others +-- to do so. +-- +-- DISCLAIMER +-- +-- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR +-- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED +-- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF 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 'FIRST AND 'LAST EXIST AND CAN BE ASSIGNED. CHECK THAT +-- 'FIRST IS LESS THAN OR EQUAL TO 'LAST. + +-- BAW 5 SEPT 80 +-- R.WILLIAMS 8/21/86 ADDED A TYPE DECLARED WITHOUT A RANGE +-- CONSTRAINT. RENAMED TO -B. ADDED EXCEPTION +-- HANDLERS. +-- GMT 6/29/87 MOVED THE CALL TO REPORT.TEST INTO A NEWLY +-- CREATED PACKAGE NAMED SHOW_TEST_HEADER. + + +WITH REPORT; USE REPORT; +PROCEDURE C35703A IS + + TYPE REAL1 IS DIGITS 2 RANGE 0.25..0.5; + TYPE REAL2 IS DIGITS 3; + + PACKAGE SHOW_TEST_HEADER IS + -- PURPOSE OF THIS PACKAGE: + -- WE WANT THE TEST HEADER INFORMATION TO BE + -- PRINTED BEFORE ANY OF THE PASS/FAIL MESSAGES. + END SHOW_TEST_HEADER; + + PACKAGE BODY SHOW_TEST_HEADER IS + BEGIN + TEST( "C35703A", + "CHECK THAT FIRST AND LAST CAN BE ASSIGNED " & + "AND THAT FIRST <= LAST" ); + END SHOW_TEST_HEADER; + + PACKAGE XPKG IS + X : REAL1; + END XPKG; + + PACKAGE BODY XPKG IS + BEGIN + X := REAL1'FIRST; + EXCEPTION + WHEN CONSTRAINT_ERROR => + FAILED ( "CONSTRAINT_ERROR RAISED BY ASSIGNMENT OF " & + "REAL1'FIRST" ); + WHEN OTHERS => + FAILED ( "OTHER EXCEPTION RAISED BY ASSIGNMENT OF " & + "REAL1'FIRST" ); + END XPKG; + + PACKAGE YPKG IS + Y : REAL1; + END YPKG; + + PACKAGE BODY YPKG IS + BEGIN + Y := REAL1'LAST; + EXCEPTION + WHEN CONSTRAINT_ERROR => + FAILED ( "CONSTRAINT_ERROR RAISED BY ASSIGNMENT OF " & + "REAL1'LAST" ); + WHEN OTHERS => + FAILED ( "OTHER EXCEPTION RAISED BY ASSIGNMENT OF " & + "REAL1'LAST" ); + END YPKG; + + PACKAGE APKG IS + A : REAL2; + END APKG; + + PACKAGE BODY APKG IS + BEGIN + A := REAL2'FIRST; + EXCEPTION + WHEN CONSTRAINT_ERROR => + FAILED ( "CONSTRAINT_ERROR RAISED BY ASSIGNMENT OF " & + "REAL2'FIRST" ); + WHEN OTHERS => + FAILED ( "OTHER EXCEPTION RAISED BY ASSIGNMENT OF " & + "REAL2'FIRST" ); + END APKG; + + PACKAGE BPKG IS + B : REAL2; + END BPKG; + + PACKAGE BODY BPKG IS + BEGIN + B := REAL2'LAST; + EXCEPTION + WHEN CONSTRAINT_ERROR => + FAILED ( "CONSTRAINT_ERROR RAISED BY ASSIGNMENT OF " & + "REAL2'LAST" ); + WHEN OTHERS => + FAILED ( "OTHER EXCEPTION RAISED BY ASSIGNMENT OF " & + "REAL2'LAST" ); + END BPKG; + + +BEGIN + + DECLARE + USE XPKG; + USE YPKG; + BEGIN + IF X > Y THEN + FAILED ( "REAL1'FIRST IS GREATER THAN REAL1'LAST" ); + END IF; + END; + + DECLARE + USE APKG; + USE BPKG; + BEGIN + IF A > B THEN + FAILED ( "REAL2'FIRST IS GREATER THEN REAL2'LAST" ); + END IF; + END; + + RESULT; + +END C35703A; diff --git a/gcc-4.9/gcc/testsuite/ada/acats/tests/c3/c35704a.ada b/gcc-4.9/gcc/testsuite/ada/acats/tests/c3/c35704a.ada new file mode 100644 index 000000000..e1e8532f4 --- /dev/null +++ b/gcc-4.9/gcc/testsuite/ada/acats/tests/c3/c35704a.ada @@ -0,0 +1,60 @@ +-- C35704A.ADA + +-- Grant of Unlimited Rights +-- +-- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687, +-- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained +-- unlimited rights in the software and documentation contained herein. +-- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making +-- this public release, the Government intends to confer upon all +-- recipients unlimited rights equal to those held by the Government. +-- These rights include rights to use, duplicate, release or disclose the +-- released technical data and computer software in whole or in part, in +-- any manner and for any purpose whatsoever, and to have or permit others +-- to do so. +-- +-- DISCLAIMER +-- +-- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR +-- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED +-- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF 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 FIXED POINT VALUES CAN BE USED IN FLOATING POINT RANGE +-- CONSTRAINT IN TYPE DEFINITION. + +-- BAW 9/5/80 +-- JCR 4/7/82 + +WITH REPORT; +PROCEDURE C35704A IS + + USE REPORT; + +BEGIN + TEST ("C35704A","CHECK THAT L AND R CAN BE FIXED POINT" & + " IN A FLOATING POINT TYPE DEFINITION"); + + DECLARE + + + TYPE F IS DELTA 0.5 RANGE -5.0..5.0; + + F1 : CONSTANT F := -4.0; + F2 : CONSTANT F := 4.0; + + TYPE G1 IS DIGITS 5 RANGE F1..F2; + BEGIN + + IF (ABS(G1'FIRST)-4.0) /= 0.0 OR + (ABS(G1'LAST)-4.0) /= 0.0 + THEN FAILED ("ERROR IN USING FIXED-POINT IN RANGE " & + "CONSTRAINT"); + END IF; + + END; + RESULT; + +END C35704A; diff --git a/gcc-4.9/gcc/testsuite/ada/acats/tests/c3/c35704b.ada b/gcc-4.9/gcc/testsuite/ada/acats/tests/c3/c35704b.ada new file mode 100644 index 000000000..7efae7783 --- /dev/null +++ b/gcc-4.9/gcc/testsuite/ada/acats/tests/c3/c35704b.ada @@ -0,0 +1,62 @@ +-- C35704B.ADA + +-- Grant of Unlimited Rights +-- +-- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687, +-- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained +-- unlimited rights in the software and documentation contained herein. +-- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making +-- this public release, the Government intends to confer upon all +-- recipients unlimited rights equal to those held by the Government. +-- These rights include rights to use, duplicate, release or disclose the +-- released technical data and computer software in whole or in part, in +-- any manner and for any purpose whatsoever, and to have or permit others +-- to do so. +-- +-- DISCLAIMER +-- +-- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR +-- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED +-- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF 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 DIFFERENT FLOATING POINT TYPES FROM SAME PARENT CAN BE +-- USED IN A FLOATING POINT RANGE CONSTRAINT IN A TYPE DEFINITION. + +-- JCR 4/7/82 + +WITH REPORT; +PROCEDURE C35704B IS + + USE REPORT; + +BEGIN + TEST ("C35704B", "DIFFERENT FLOATING POINT TYPES " & + "FROM THE SAME PARENT IN FLOATING POINT" & + "TYPE DEFINITION'S RANGE CONSTRAINT"); + + DECLARE + TYPE F IS DIGITS 5 RANGE -5.0 .. 5.0; + + TYPE F1 IS NEW F; + + TYPE G1 IS DIGITS 5 RANGE F1'FIRST..F'LAST; + TYPE G2 IS DIGITS 5 RANGE F'FIRST..F1'LAST; + + BEGIN + + IF G1'FIRST /= G1(G2'FIRST) OR G1'LAST /= G1(G2'LAST) OR + G2'FIRST /= G2(F'FIRST) OR G2'LAST /= G2(F'LAST) + THEN + FAILED ("USING DIFF FLOATING POINT TYPES " & + "FROM SAME PARENT"); + + END IF; + + END; + + RESULT; + +END C35704B; diff --git a/gcc-4.9/gcc/testsuite/ada/acats/tests/c3/c35704c.ada b/gcc-4.9/gcc/testsuite/ada/acats/tests/c3/c35704c.ada new file mode 100644 index 000000000..2b0fe3b32 --- /dev/null +++ b/gcc-4.9/gcc/testsuite/ada/acats/tests/c3/c35704c.ada @@ -0,0 +1,62 @@ +-- C35704C.ADA + +-- Grant of Unlimited Rights +-- +-- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687, +-- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained +-- unlimited rights in the software and documentation contained herein. +-- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making +-- this public release, the Government intends to confer upon all +-- recipients unlimited rights equal to those held by the Government. +-- These rights include rights to use, duplicate, release or disclose the +-- released technical data and computer software in whole or in part, in +-- any manner and for any purpose whatsoever, and to have or permit others +-- to do so. +-- +-- DISCLAIMER +-- +-- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR +-- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED +-- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF 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 DIFFERENT FLOATING POINT TYPES FROM DIFFERENT PARENTS +-- CAN BE USE IN FLOATING POINT RANGE CONSTRAINTS IN TYPE DEFINITIONS. + +-- JCR 4/7/82 + +WITH REPORT; +PROCEDURE C35704C IS + + USE REPORT; + +BEGIN + TEST ("C35704C", "DIFFERENT FLOATING POINT TYPES " & + "FROM DIFFERENT PARENTS IN FLOATING POINT RANGE " & + "CONSTRAINT IN TYPE DEFINITION"); + + DECLARE + + TYPE F IS DIGITS 5 RANGE -5.0 .. 5.0; + TYPE F1 IS DIGITS 5 RANGE -5.0 .. 5.0; + + TYPE G1 IS DIGITS 5 RANGE F'FIRST..F1'LAST; + TYPE G2 IS DIGITS 5 RANGE F1'FIRST..F'LAST; + + BEGIN + + + IF G1'FIRST /= G1(F'FIRST) OR G1'FIRST /= G1(G2'FIRST) OR + G1'FIRST /= G1(F1'FIRST) OR G1'LAST /= G1(F'LAST) OR + G1'LAST /= G1(G2'LAST) OR G1'LAST /= G1(F1'LAST) + + THEN FAILED ("USING FLOAT FROM DIFF PARENTS"); + + END IF; + END; + + RESULT; + +END C35704C; diff --git a/gcc-4.9/gcc/testsuite/ada/acats/tests/c3/c35704d.ada b/gcc-4.9/gcc/testsuite/ada/acats/tests/c3/c35704d.ada new file mode 100644 index 000000000..0afd81de1 --- /dev/null +++ b/gcc-4.9/gcc/testsuite/ada/acats/tests/c3/c35704d.ada @@ -0,0 +1,70 @@ +-- C35704D.ADA + +-- Grant of Unlimited Rights +-- +-- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687, +-- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained +-- unlimited rights in the software and documentation contained herein. +-- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making +-- this public release, the Government intends to confer upon all +-- recipients unlimited rights equal to those held by the Government. +-- These rights include rights to use, duplicate, release or disclose the +-- released technical data and computer software in whole or in part, in +-- any manner and for any purpose whatsoever, and to have or permit others +-- to do so. +-- +-- DISCLAIMER +-- +-- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR +-- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED +-- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF 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 COMBINATION OF FIXED AND FLOAT CAN BE USED IN A +-- FLOATING POINT RANGE CONSTRAINT IN A TYPE DEFINITION. + +-- JCR 4/7/82 + +WITH REPORT; +PROCEDURE C35704D IS + + USE REPORT; + +BEGIN + TEST ("C35704D","MIXED FIXED AND FLOAT IN FLOATING " & + "POINT RANGE CONSTRAINT IN A TYPE DEFINITION"); + + DECLARE + + TYPE F IS DIGITS 5; + TYPE R IS DELTA 0.5 RANGE -5.0 .. 5.0; + + T1 : CONSTANT F := -4.0; + T2 : CONSTANT F := 4.0; + + R1 : CONSTANT R := -4.0; + R2 : CONSTANT R := 4.0; + + TYPE G1 IS DIGITS 5 RANGE T1..R2; + TYPE G2 IS DIGITS 5 RANGE R1..T2; + + BEGIN + + IF (ABS(G1'FIRST)- 4.0) /= 0.0 OR + (ABS(G1'LAST) - 4.0) /= 0.0 OR + (ABS(G2'FIRST)- 4.0) /= 0.0 OR + (ABS(G2'LAST) - 4.0) /= 0.0 + + THEN FAILED ("MIXED FIXED AND FLOAT IN FLOAT RANGE " & + "CONSTRAINT"); + + END IF; + + END; + + RESULT; + + +END C35704D; diff --git a/gcc-4.9/gcc/testsuite/ada/acats/tests/c3/c35801d.ada b/gcc-4.9/gcc/testsuite/ada/acats/tests/c3/c35801d.ada new file mode 100644 index 000000000..5ee825904 --- /dev/null +++ b/gcc-4.9/gcc/testsuite/ada/acats/tests/c3/c35801d.ada @@ -0,0 +1,79 @@ +-- C35801D.ADA + +-- Grant of Unlimited Rights +-- +-- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687, +-- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained +-- unlimited rights in the software and documentation contained herein. +-- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making +-- this public release, the Government intends to confer upon all +-- recipients unlimited rights equal to those held by the Government. +-- These rights include rights to use, duplicate, release or disclose the +-- released technical data and computer software in whole or in part, in +-- any manner and for any purpose whatsoever, and to have or permit others +-- to do so. +-- +-- DISCLAIMER +-- +-- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR +-- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED +-- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF 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 ATTRIBUTES FIRST AND LAST RETURN VALUES HAVING THE +-- SAME BASE TYPE AS THE PREFIX WHEN THE PREFIX IS A GENERIC FORMAL +-- SUBTYPE WHOSE ACTUAL ARGUMENT IS A FLOATING POINT TYPE. + +-- R.WILLIAMS 8/21/86 + +WITH REPORT; USE REPORT; +PROCEDURE C35801D IS + TYPE REAL IS DIGITS 3 RANGE -100.0 .. 100.0; + + TYPE NFLT IS NEW FLOAT; + + GENERIC + TYPE F IS DIGITS <>; + PROCEDURE P (STR : STRING); + + PROCEDURE P (STR : STRING) IS + + SUBTYPE SF IS F RANGE -1.0 .. 1.0; + F1 : SF := 0.0; + F2 : SF := 0.0; + + BEGIN + IF EQUAL (3, 3) THEN + F1 := SF'FIRST; + F2 := SF'LAST; + END IF; + + IF F1 /= -1.0 OR F2 /= 1.0 THEN + FAILED ( "WRONG RESULTS FROM " & STR & "'FIRST OR " & + STR & "'LAST" ); + END IF; + END P; + + PROCEDURE NP1 IS NEW P (FLOAT); + + PROCEDURE NP2 IS NEW P (NFLT); + + PROCEDURE NP3 IS NEW P (REAL); + +BEGIN + TEST ( "C35801D", "CHECK THAT THE ATTRIBUTES FIRST AND " & + "LAST RETURN VALUES HAVING THE SAME " & + "BASE TYPE AS THE PREFIX WHEN THE " & + "PREFIX IS A GENERIC FORMAL SUBTYPE " & + "WHOSE ACTUAL ARGUMENT IS A FLOATING " & + "POINT TYPE" ); + + + NP1 ("FLOAT"); + NP2 ("NFLT"); + NP3 ("REAL"); + + RESULT; +END C35801D; diff --git a/gcc-4.9/gcc/testsuite/ada/acats/tests/c3/c35902d.ada b/gcc-4.9/gcc/testsuite/ada/acats/tests/c3/c35902d.ada new file mode 100644 index 000000000..c09fe5894 --- /dev/null +++ b/gcc-4.9/gcc/testsuite/ada/acats/tests/c3/c35902d.ada @@ -0,0 +1,121 @@ +-- C35902D.ADA + +-- Grant of Unlimited Rights +-- +-- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687, +-- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained +-- unlimited rights in the software and documentation contained herein. +-- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making +-- this public release, the Government intends to confer upon all +-- recipients unlimited rights equal to those held by the Government. +-- These rights include rights to use, duplicate, release or disclose the +-- released technical data and computer software in whole or in part, in +-- any manner and for any purpose whatsoever, and to have or permit others +-- to do so. +-- +-- DISCLAIMER +-- +-- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR +-- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED +-- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF 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 BINARY POINT IN THE MANTISSA OF A FIXED POINT NUMBER +-- CAN LIE OUTSIDE THE MANTISSA (EITHER TO THE LEFT OR TO THE RIGHT). + +-- WRG 7/18/86 + +WITH REPORT; USE REPORT; +WITH SYSTEM; USE SYSTEM; +PROCEDURE C35902D IS + +BEGIN + + TEST ("C35902D", "CHECK THAT THE BINARY POINT IN THE MANTISSA " & + "OF A FIXED POINT NUMBER CAN LIE OUTSIDE THE " & + "MANTISSA (EITHER TO THE LEFT OR TO THE RIGHT)"); + + COMMENT ("VALUE OF SYSTEM.MAX_MANTISSA IS" & + POSITIVE'IMAGE(MAX_MANTISSA) ); + + A: DECLARE + + RS : CONSTANT := 2.0; + + TYPE ONE_TO_THE_RIGHT IS + DELTA RS + RANGE -(2.0 ** (MAX_MANTISSA+1) ) .. + 2.0 ** (MAX_MANTISSA+1); + -- THE BINARY POINT IS ONE PLACE TO THE RIGHT OF THE + -- LARGEST POSSIBLE MANTISSA. + + R1, R2 : ONE_TO_THE_RIGHT; + + BEGIN + + R1 := RS; + FOR I IN POSITIVE RANGE 1 .. MAX_MANTISSA - 1 LOOP + R1 := R1 * IDENT_INT (2); + END LOOP; + R2 := R1 - RS; + R2 := R2 + R1; + -- AT THIS POINT, R2 SHOULD EQUAL ONE_TO_THE_RIGHT'LARGE. + R2 := -R2; + R2 := R2 + (R1 - RS); + FOR I IN POSITIVE RANGE 1 .. MAX_MANTISSA - 1 LOOP + R2 := R2 / IDENT_INT (2); + END LOOP; + IF R2 /= -RS THEN + FAILED ("IDENTITY-PRESERVING OPERATIONS ARE FLAKY - A"); + END IF; + + EXCEPTION + + WHEN OTHERS => + FAILED ("EXCEPTION RAISED - A"); + + END A; + + B: DECLARE + + LS : CONSTANT := 2.0 ** (-(MAX_MANTISSA+1) ); + + TYPE ONE_TO_THE_LEFT IS + DELTA LS + RANGE -(2.0 ** (-1) ) .. + 2.0 ** (-1); + -- THE BINARY POINT IS ONE PLACE TO THE LEFT OF THE + -- LARGEST POSSIBLE MANTISSA. + + L1, L2 : ONE_TO_THE_LEFT; + + BEGIN + + L1 := LS; + FOR I IN POSITIVE RANGE 1 .. MAX_MANTISSA - 1 LOOP + L1 := L1 * IDENT_INT (2); + END LOOP; + L2 := L1 - LS; + L2 := L2 + L1; + -- AT THIS POINT, L2 SHOULD EQUAL ONE_TO_THE_LEFT'LARGE. + L2 := -L2; + L2 := L2 + (L1 - LS); + FOR I IN POSITIVE RANGE 1 .. MAX_MANTISSA - 1 LOOP + L2 := L2 / IDENT_INT (2); + END LOOP; + IF L2 /= -LS THEN + FAILED ("IDENTITY-PRESERVING OPERATIONS ARE FLAKY - B"); + END IF; + + EXCEPTION + + WHEN OTHERS => + FAILED ("EXCEPTION RAISED - B"); + + END B; + + RESULT; + +END C35902D; diff --git a/gcc-4.9/gcc/testsuite/ada/acats/tests/c3/c35904a.ada b/gcc-4.9/gcc/testsuite/ada/acats/tests/c3/c35904a.ada new file mode 100644 index 000000000..8b3bfbba6 --- /dev/null +++ b/gcc-4.9/gcc/testsuite/ada/acats/tests/c3/c35904a.ada @@ -0,0 +1,103 @@ +-- C35904A.ADA + +-- Grant of Unlimited Rights +-- +-- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687, +-- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained +-- unlimited rights in the software and documentation contained herein. +-- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making +-- this public release, the Government intends to confer upon all +-- recipients unlimited rights equal to those held by the Government. +-- These rights include rights to use, duplicate, release or disclose the +-- released technical data and computer software in whole or in part, in +-- any manner and for any purpose whatsoever, and to have or permit others +-- to do so. +-- +-- DISCLAIMER +-- +-- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR +-- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED +-- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF 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 INCOMPATIBLE FIXED POINT CONSTRAINTS RAISE +-- APPROPRIATE EXCEPTIONS. + + +-- HISTORY: +-- RJK 05/17/83 CREATED ORIGINAL TEST. +-- PWB 02/03/86 CORRECTED TEST ERROR: +-- ADDED POSSIBLITY OF NUMERIC_ERROR +-- IN DECLARATIONS OF SFX3 AND SFX4. +-- BCB 10/21/87 CHANGED HEADER TO STANDARD FORMAT. CHANGED RANGE +-- CONSTRAINTS OF SUBTYPE SFX1. CHANGED UPPER BOUND +-- OF THE CONSTRAINT OF SFX4. CHANGED RANGE +-- CONSTRAINTS OF FIX. +-- JRL 03/30/93 REMOVED NUMERIC_ERROR FROM TEST. +-- PWN 10/27/95 REMOVED OUT OF RANGE STATIC VALUE CHECKS. +-- EDS 07/16/98 AVOID OPTIMIZATION + +WITH REPORT; USE REPORT; +PROCEDURE C35904A IS + + TYPE FIX IS DELTA 0.5 RANGE -3.0 .. 3.0; + +BEGIN + + TEST ("C35904A", "CHECK THAT INCOMPATIBLE FIXED POINT " & + "CONSTRAINTS RAISE APPROPRIATE EXCEPTION"); + +-- TEST FOR CORRECT SUBTYPE DEFINITION FOR COMPATIBILITY BETWEEN TYPE +-- AND SUBTYPE CONSTRAINTS. + + BEGIN + + DECLARE + + SUBTYPE SFX1 IS FIX DELTA 1.0 RANGE 0.0 .. 2.0; -- OK. + SFX1_VAR : SFX1; + + BEGIN + SFX1_VAR := 1.0; + END; + + EXCEPTION + WHEN CONSTRAINT_ERROR => + FAILED ("FIXED POINT CONSTRAINTS ARE NOT IN ERROR"); + WHEN OTHERS => + FAILED ("EXCEPTION SHOULD NOT BE RAISED WHILE " & + "CHECKING DELTA CONSTRAINT"); + END; + +-- TEST FOR INCORRECT SUBTYPE DEFINITION ON ACCURACY BETWEEN TYPE AND +-- SUBTYPE DEFINITIONS. + + BEGIN + + DECLARE + + SUBTYPE SFX IS FIX DELTA 0.1; -- DELTA IS SMALLER FOR + -- SUBTYPE THAN FOR TYPE. + -- DEFINE AN OBJECT OF SUBTYPE SFX AND USE IT TO AVOID + -- OPTIMIZATION OF SUBTYPE + SFX_VAR : SFX := FIX(IDENT_INT(1)); + + BEGIN + FAILED ("NO EXCEPTION RAISED FOR INCOMPATABLE DELTA " & + FIX'IMAGE(SFX_VAR) ); --USE SFX_VAR + END; + + EXCEPTION + WHEN CONSTRAINT_ERROR => + NULL; + WHEN OTHERS => + FAILED ("INCORRECT EXCEPTION RAISED WHILE CHECKING " & + "DELTA CONSTRAINT"); + END; + + RESULT; + +END C35904A; diff --git a/gcc-4.9/gcc/testsuite/ada/acats/tests/c3/c35904b.ada b/gcc-4.9/gcc/testsuite/ada/acats/tests/c3/c35904b.ada new file mode 100644 index 000000000..cff7d2ec8 --- /dev/null +++ b/gcc-4.9/gcc/testsuite/ada/acats/tests/c3/c35904b.ada @@ -0,0 +1,136 @@ +-- C35904B.ADA + +-- Grant of Unlimited Rights +-- +-- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687, +-- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained +-- unlimited rights in the software and documentation contained herein. +-- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making +-- this public release, the Government intends to confer upon all +-- recipients unlimited rights equal to those held by the Government. +-- These rights include rights to use, duplicate, release or disclose the +-- released technical data and computer software in whole or in part, in +-- any manner and for any purpose whatsoever, and to have or permit others +-- to do so. +-- +-- DISCLAIMER +-- +-- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR +-- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED +-- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF 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 INCOMPATIBLE FIXED POINT CONSTRAINTS RAISE +-- CONSTRAINT_ERROR FOR GENERIC FORMAL TYPES. + +-- *** NOTE: This test has been modified since ACVC version 1.11 to -- 9X +-- *** remove incompatibilities associated with the transition -- 9X +-- *** to Ada 9X. -- 9X + +-- RJW 6/20/86 +-- DWC 07/24/87 -- ADDED NUMERIC_ERROR HANDLERS. +-- JRL 03/30/93 REMOVED NUMERIC_ERROR FROM TEST. +-- EDS 07/16/98 AVOID OPTIMIZATION + +WITH REPORT; USE REPORT; +PROCEDURE C35904B IS + + GENERIC + TYPE FIX IS DELTA <>; + PROCEDURE PROC (STR : STRING); + + PROCEDURE PROC (STR : STRING) IS + SUBTYPE SFIX IS FIX DELTA 0.1 RANGE -1.0 .. 1.0; + -- DEFINE AN OBJECT OF SUBTYPE SFIX AND USE IT TO AVOID + -- OPTIMIZATION OF SUBTYPE + SFIX_VAR : SFIX := SFIX(IDENT_INT(0)); + BEGIN + FAILED ("NO EXCEPTION RAISED FOR " & STR & " " & + SFIX'IMAGE(SFIX_VAR) ); --USE SFIX_VAR + END PROC; + +BEGIN + + TEST ( "C35904B", "CHECK THAT INCOMPATIBLE FIXED POINT " & + "CONSTRAINTS RAISE CONSTRAINT_ERROR " & + "FOR GENERIC FORMAL TYPES" ); + +-- TEST FOR INCORRECT SUBTYPE DEFINITION ON ACCURACY BETWEEN TYPE AND +-- SUBTYPE DEFINITIONS. + + BEGIN + + DECLARE + + TYPE FIX1 IS DELTA 0.5 -- DELTA IS SMALLER FOR + RANGE -2.0 .. 2.0; -- SUBTYPE THEN FOR + -- TYPE. + + PROCEDURE NPROC IS NEW PROC (FIX1); + + BEGIN + NPROC ( "INCOMPATIBLE DELTA" ); + END; + + EXCEPTION + WHEN CONSTRAINT_ERROR => + NULL; + WHEN OTHERS => + FAILED ("INCORRECT EXCEPTION RAISED WHILE CHECKING " & + "DELTA CONSTRAINT"); + END; + +-- TEST THAT CONSTRAINT_ERROR IS RAISED +-- FOR A RANGE VIOLATION. + + BEGIN + + DECLARE + + TYPE FIX2 IS DELTA 0.1 RANGE 0.0 .. 2.0; -- LOWER + -- BOUND. + + PROCEDURE NPROC IS NEW PROC (FIX2); + + BEGIN + NPROC ("FIXED POINT LOWER BOUND CONSTRAINT VIOLATION"); + END; + + EXCEPTION + WHEN CONSTRAINT_ERROR => + COMMENT ("CONSTRAINT_ERROR RAISED FOR " & + "LOWER BOUND VIOLATION"); + WHEN OTHERS => + FAILED ("INCORRECT EXCEPTION RAISED WHILE CHECKING " & + "FIXED POINT LOWER BOUND CONSTRAINT"); + END; + +-- TEST THAT CONSTRAINT_ERROR IS RAISED +-- FOR A RANGE VIOLATION. + + BEGIN + + DECLARE + + TYPE FIX3 IS DELTA 0.1 RANGE -2.0 .. 0.0; -- UPPER + -- BOUND. + + PROCEDURE NPROC IS NEW PROC (FIX3); + BEGIN + NPROC ("FIXED POINT UPPER BOUND CONSTRAINT VIOLATION"); + END; + + EXCEPTION + WHEN CONSTRAINT_ERROR => + COMMENT ("CONSTRAINT_ERROR RAISED FOR " & + "UPPER BOUND VIOLATION"); + WHEN OTHERS => + FAILED ("INCORRECT EXCEPTION RAISED WHILE CHECKING " & + "FIXED POINT UPPER BOUND CONSTRAINT"); + END; + + RESULT; + +END C35904B; diff --git a/gcc-4.9/gcc/testsuite/ada/acats/tests/c3/c35a02a.ada b/gcc-4.9/gcc/testsuite/ada/acats/tests/c3/c35a02a.ada new file mode 100644 index 000000000..5ebee358d --- /dev/null +++ b/gcc-4.9/gcc/testsuite/ada/acats/tests/c3/c35a02a.ada @@ -0,0 +1,75 @@ +-- C35A02A.ADA + +-- Grant of Unlimited Rights +-- +-- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687, +-- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained +-- unlimited rights in the software and documentation contained herein. +-- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making +-- this public release, the Government intends to confer upon all +-- recipients unlimited rights equal to those held by the Government. +-- These rights include rights to use, duplicate, release or disclose the +-- released technical data and computer software in whole or in part, in +-- any manner and for any purpose whatsoever, and to have or permit others +-- to do so. +-- +-- DISCLAIMER +-- +-- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR +-- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED +-- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF 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 T'DELTA YIELDS CORRECT VALUES FOR SUBTYPE T. + +-- RJW 2/27/86 + +WITH REPORT; USE REPORT; + +PROCEDURE C35A02A IS + +BEGIN + + TEST ( "C35A02A", "CHECK THAT T'DELTA YIELDS CORRECT VALUES " & + "FOR SUBTYPE T" ); + + DECLARE + D : CONSTANT := 0.125; + SD : CONSTANT := 1.0; + + TYPE VOLT IS DELTA D RANGE 0.0 .. 255.0; + SUBTYPE ROUGH_VOLTAGE IS VOLT DELTA SD; + + GENERIC + TYPE FIXED IS DELTA <> ; + FUNCTION F RETURN FIXED; + + FUNCTION F RETURN FIXED IS + BEGIN + RETURN FIXED'DELTA; + END F; + + FUNCTION VF IS NEW F (VOLT); + FUNCTION RF IS NEW F (ROUGH_VOLTAGE); + + BEGIN + IF VOLT'DELTA /= D THEN + FAILED ( "INCORRECT VALUE FOR VOLT'DELTA" ); + END IF; + IF ROUGH_VOLTAGE'DELTA /= SD THEN + FAILED ( "INCORRECT VALUE FOR ROUGH_VOLTAGE'DELTA" ); + END IF; + + IF VF /= D THEN + FAILED ( "INCORRECT VALUE FOR VF" ); + END IF; + IF RF /= SD THEN + FAILED ( "INCORRECT VALUE FOR RF" ); + END IF; + END; + + RESULT; + +END C35A02A; diff --git a/gcc-4.9/gcc/testsuite/ada/acats/tests/c3/c35a05a.ada b/gcc-4.9/gcc/testsuite/ada/acats/tests/c3/c35a05a.ada new file mode 100644 index 000000000..c850249d4 --- /dev/null +++ b/gcc-4.9/gcc/testsuite/ada/acats/tests/c3/c35a05a.ada @@ -0,0 +1,153 @@ +-- C35A05A.ADA + +-- Grant of Unlimited Rights +-- +-- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687, +-- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained +-- unlimited rights in the software and documentation contained herein. +-- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making +-- this public release, the Government intends to confer upon all +-- recipients unlimited rights equal to those held by the Government. +-- These rights include rights to use, duplicate, release or disclose the +-- released technical data and computer software in whole or in part, in +-- any manner and for any purpose whatsoever, and to have or permit others +-- to do so. +-- +-- DISCLAIMER +-- +-- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR +-- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED +-- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE +-- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE +-- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A +-- PARTICULAR PURPOSE OF SAID MATERIAL. +--* +-- CHECK THAT FOR FIXED POINT TYPES THE FORE AND AFT ATTRIBUTES YIELD +-- THE CORRECT VALUES. + +-- CASE A: BASIC TYPES THAT FIT THE CHARACTERISTICS OF DURATION'BASE. + +-- WRG 8/8/86 + +WITH REPORT; USE REPORT; +PROCEDURE C35A05A IS + + -- THE NAME OF EACH TYPE OR SUBTYPE ENDS WITH THAT TYPE'S + -- 'MANTISSA VALUE. + + TYPE LEFT_OUT_M1 IS DELTA 0.25 RANGE -0.5 .. 0.5; + TYPE LEFT_EDGE_M1 IS DELTA 0.5 RANGE -1.0 .. 1.0; + TYPE RIGHT_EDGE_M1 IS DELTA 1.0 RANGE -2.0 .. 2.0; + TYPE RIGHT_OUT_M1 IS DELTA 2.0 RANGE -4.0 .. 4.0; + TYPE MIDDLE_M2 IS DELTA 0.5 RANGE -2.0 .. 2.0; + TYPE MIDDLE_M3 IS DELTA 0.5 RANGE 0.0 .. 2.5; + TYPE MIDDLE_M15 IS DELTA 2.0 **(-6) RANGE -512.0 .. 512.0; + TYPE MIDDLE_M16 IS DELTA 2.0 **(-6) RANGE -1024.0 .. 1024.0; + TYPE LIKE_DURATION_M23 IS DELTA 0.020 RANGE -86_400.0 .. 86_400.0; + TYPE DECIMAL_M18 IS DELTA 0.1 RANGE -10_000.0 .. 10_000.0; + TYPE DECIMAL_M4 IS DELTA 100.0 RANGE -1000.0 .. 1000.0; + TYPE DECIMAL_M11 IS DELTA 0.09999 RANGE -100.0 .. 100.0; + TYPE DECIMAL2_M18 IS DELTA 0.1 RANGE -9999.0 .. 9999.0; + + ------------------------------------------------------------------- + + SUBTYPE ST_LEFT_EDGE_M6 IS MIDDLE_M15 + DELTA 2.0 ** (-6) RANGE IDENT_INT (1) * (-1.0) .. 1.0; + SUBTYPE ST_MIDDLE_M14 IS MIDDLE_M16 + DELTA 2.0 ** (-5) RANGE -512.0 .. IDENT_INT (1) * 512.0; + SUBTYPE ST_MIDDLE_M2 IS LIKE_DURATION_M23 + DELTA 0.5 RANGE -2.0 .. 2.0; + SUBTYPE ST_MIDDLE_M3 IS LIKE_DURATION_M23 + DELTA 0.5 RANGE 0.0 .. 2.5; + SUBTYPE ST_DECIMAL_M7 IS DECIMAL_M18 + DELTA 10.0 RANGE -1000.0 .. 1000.0; + SUBTYPE ST_DECIMAL_M3 IS DECIMAL_M4 + DELTA 100.0 RANGE -500.0 .. 500.0; + + ------------------------------------------------------------------- + + PROCEDURE CHECK_FORE_AND_AFT + (NAME : STRING; + ACTUAL_FORE : INTEGER; CORRECT_FORE : POSITIVE; + ACTUAL_AFT : INTEGER; CORRECT_AFT : POSITIVE) IS + BEGIN + IF ACTUAL_FORE /= IDENT_INT (CORRECT_FORE) THEN + FAILED (NAME & "'FORE =" & INTEGER'IMAGE(ACTUAL_FORE) ); + END IF; + IF ACTUAL_AFT /= IDENT_INT (CORRECT_AFT) THEN + FAILED (NAME & "'AFT =" & INTEGER'IMAGE(ACTUAL_AFT) ); + END IF; + END CHECK_FORE_AND_AFT; + +BEGIN + + TEST ("C35A05A", "CHECK THAT FOR FIXED POINT TYPES THE FORE AND " & + "AFT ATTRIBUTES YIELD THE CORRECT VALUES - " & + "BASIC TYPES"); + + CHECK_FORE_AND_AFT ("LEFT_OUT_M1", LEFT_OUT_M1'FORE, 2, + LEFT_OUT_M1'AFT, 1); + + CHECK_FORE_AND_AFT ("LEFT_EDGE_M1", LEFT_EDGE_M1'FORE, 2, + LEFT_EDGE_M1'AFT, 1); + + CHECK_FORE_AND_AFT ("RIGHT_EDGE_M1", RIGHT_EDGE_M1'FORE, 2, + RIGHT_EDGE_M1'AFT, 1); + + CHECK_FORE_AND_AFT ("RIGHT_OUT_M1", RIGHT_OUT_M1'FORE, 2, + RIGHT_OUT_M1'AFT, 1); + + CHECK_FORE_AND_AFT ("MIDDLE_M2", MIDDLE_M2'FORE, 2, + MIDDLE_M2'AFT, 1); + + CHECK_FORE_AND_AFT ("MIDDLE_M3", MIDDLE_M3'FORE, 2, + MIDDLE_M3'AFT, 1); + + CHECK_FORE_AND_AFT ("MIDDLE_M15", MIDDLE_M15'FORE, 4, + MIDDLE_M15'AFT, 2); + + CHECK_FORE_AND_AFT ("MIDDLE_M16", MIDDLE_M16'FORE, 5, + MIDDLE_M16'AFT, 2); + + CHECK_FORE_AND_AFT ("LIKE_DURATION_M23", LIKE_DURATION_M23'FORE, 6, + LIKE_DURATION_M23'AFT, 2); + + CHECK_FORE_AND_AFT ("DECIMAL_M18", DECIMAL_M18'FORE, 6, + DECIMAL_M18'AFT, 1); + + IF DECIMAL_M4'FORE /= 5 AND DECIMAL_M4'FORE /= 4 THEN + FAILED ("DECIMAL_M4'FORE =" & + INTEGER'IMAGE(DECIMAL_M4'FORE) ); + END IF; + IF DECIMAL_M4'AFT /= 1 THEN + FAILED ("DECIMAL_M4'AFT =" & + INTEGER'IMAGE(DECIMAL_M4'AFT) ); + END IF; + + CHECK_FORE_AND_AFT ("DECIMAL_M11", DECIMAL_M11'FORE, 4, + DECIMAL_M11'AFT, 2); + + CHECK_FORE_AND_AFT ("DECIMAL2_M18", DECIMAL2_M18'FORE, 5, + DECIMAL2_M18'AFT, 1); + + CHECK_FORE_AND_AFT ("ST_LEFT_EDGE_M6", ST_LEFT_EDGE_M6'FORE, 2, + ST_LEFT_EDGE_M6'AFT, 2); + + CHECK_FORE_AND_AFT ("ST_MIDDLE_M14", ST_MIDDLE_M14'FORE, 4, + ST_MIDDLE_M14'AFT, 2); + + CHECK_FORE_AND_AFT ("ST_MIDDLE_M2", ST_MIDDLE_M2'FORE, 2, + ST_MIDDLE_M2'AFT, 1); + + CHECK_FORE_AND_AFT ("ST_MIDDLE_M3", ST_MIDDLE_M3'FORE, 2, + ST_MIDDLE_M3'AFT, 1); + + CHECK_FORE_AND_AFT ("ST_DECIMAL_M7", ST_DECIMAL_M7'FORE, 5, + ST_DECIMAL_M7'AFT, 1); + + CHECK_FORE_AND_AFT ("ST_DECIMAL_M3", ST_DECIMAL_M3'FORE, 4, + ST_DECIMAL_M3'AFT, 1); + + RESULT; + +END C35A05A; diff --git a/gcc-4.9/gcc/testsuite/ada/acats/tests/c3/c35a05d.ada b/gcc-4.9/gcc/testsuite/ada/acats/tests/c3/c35a05d.ada new file mode 100644 index 000000000..9b07671f5 --- /dev/null +++ b/gcc-4.9/gcc/testsuite/ada/acats/tests/c3/c35a05d.ada @@ -0,0 +1,153 @@ +-- C35A05D.ADA + +-- Grant of Unlimited Rights +-- +-- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687, +-- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained +-- unlimited rights in the software and documentation contained herein. +-- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making +-- this public release, the Government intends to confer upon all +-- recipients unlimited rights equal to those held by the Government. +-- These rights include rights to use, duplicate, release or disclose the +-- released technical data and computer software in whole or in part, in +-- any manner and for any purpose whatsoever, and to have or permit others +-- to do so. +-- +-- DISCLAIMER +-- +-- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR +-- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED +-- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE +-- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE +-- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A +-- PARTICULAR PURPOSE OF SAID MATERIAL. +--* +-- CHECK THAT FOR FIXED POINT TYPES THE FORE AND AFT ATTRIBUTES YIELD +-- THE CORRECT VALUES. + +-- CASE D: TYPES TYPICAL OF APPLICATIONS USING FIXED POINT ARITHMETIC. + +-- WRG 8/14/86 + +WITH REPORT; USE REPORT; +PROCEDURE C35A05D IS + + PI : CONSTANT := 3.14159_26535_89793_23846; + TWO_PI : CONSTANT := 2 * PI; + HALF_PI : CONSTANT := PI / 2; + + MM : CONSTANT := 23; + + -- THE NAME OF EACH TYPE OR SUBTYPE ENDS WITH THAT TYPE'S + -- 'MANTISSA VALUE. + + TYPE MICRO_ANGLE_ERROR_M15 IS + DELTA 16.0 RANGE -(2.0 ** 19) .. 2.0 ** 19; + TYPE TRACK_RANGE_M15 IS + DELTA 0.125 RANGE -(2.0 ** 12) .. 2.0 ** 12; + TYPE SECONDS_MM IS + DELTA 2.0 ** (8 - MM) RANGE -(2.0 ** 8) .. 2.0 ** 8; + TYPE RANGE_CELL_MM IS + DELTA 2.0 ** (-5) + RANGE -(2.0 ** (MM - 5) ) .. 2.0 ** (MM - 5); + + TYPE PIXEL_M10 IS DELTA 1.0 / 1024.0 RANGE 0.0 .. 1.0; + TYPE RULER_M8 IS DELTA 1.0 / 16.0 RANGE 0.0 .. 12.0; + + TYPE HOURS_M16 IS DELTA 24.0 * 2.0 ** (-15) RANGE 0.0 .. 24.0; + TYPE MILES_M16 IS DELTA 3000.0 * 2.0 ** (-15) RANGE 0.0 .. 3000.0; + + TYPE SYMMETRIC_DEGREES_M7 IS + DELTA 2.0 RANGE -180.0 .. 180.0; + TYPE NATURAL_DEGREES_M15 IS + DELTA 2.0 ** (-6) RANGE 0.0 .. 360.0; + TYPE SYMMETRIC_RADIANS_M16 IS + DELTA PI * 2.0 ** (-15) RANGE -PI .. PI; + TYPE NATURAL_RADIANS_M8 IS + DELTA TWO_PI * 2.0 ** ( -7) RANGE 0.0 .. TWO_PI; + + ------------------------------------------------------------------- + + SUBTYPE ST_MILES_M8 IS MILES_M16 + DELTA 3000.0 * 2.0 ** (-15) RANGE 0.0 .. 10.0; + SUBTYPE ST_NATURAL_DEGREES_M11 IS NATURAL_DEGREES_M15 + DELTA 0.25 RANGE 0.0 .. 360.0; + SUBTYPE ST_SYMMETRIC_RADIANS_M8 IS SYMMETRIC_RADIANS_M16 + DELTA HALF_PI * 2.0 ** (-7) RANGE -HALF_PI .. HALF_PI; + + ------------------------------------------------------------------- + + PROCEDURE CHECK_FORE_AND_AFT + (NAME : STRING; + ACTUAL_FORE : INTEGER; CORRECT_FORE : POSITIVE; + ACTUAL_AFT : INTEGER; CORRECT_AFT : POSITIVE) IS + BEGIN + IF ACTUAL_FORE /= IDENT_INT (CORRECT_FORE) THEN + FAILED (NAME & "'FORE =" & INTEGER'IMAGE(ACTUAL_FORE) ); + END IF; + IF ACTUAL_AFT /= IDENT_INT (CORRECT_AFT) THEN + FAILED (NAME & "'AFT =" & INTEGER'IMAGE(ACTUAL_AFT) ); + END IF; + END CHECK_FORE_AND_AFT; + +BEGIN + + TEST ("C35A05D", "CHECK THAT FOR FIXED POINT TYPES THE FORE AND " & + "AFT ATTRIBUTES YIELD THE CORRECT VALUES - " & + "TYPICAL TYPES"); + + CHECK_FORE_AND_AFT ("MICRO_ANGLE_ERROR_M15", + MICRO_ANGLE_ERROR_M15'FORE, 7, + MICRO_ANGLE_ERROR_M15'AFT, 1); + + CHECK_FORE_AND_AFT ("TRACK_RANGE_M15", TRACK_RANGE_M15'FORE, 5, + TRACK_RANGE_M15'AFT, 1); + + CHECK_FORE_AND_AFT ("SECONDS_MM", SECONDS_MM'FORE, 4, + SECONDS_MM'AFT, 5); + + CHECK_FORE_AND_AFT ("RANGE_CELL_MM", RANGE_CELL_MM'FORE, 7, + RANGE_CELL_MM'AFT, 2); + + CHECK_FORE_AND_AFT ("PIXEL_M10", PIXEL_M10'FORE, 2, + PIXEL_M10'AFT, 4); + + CHECK_FORE_AND_AFT ("RULER_M8", RULER_M8'FORE, 3, + RULER_M8'AFT, 2); + + CHECK_FORE_AND_AFT ("HOURS_M16", HOURS_M16'FORE, 3, + HOURS_M16'AFT, 4); + + CHECK_FORE_AND_AFT ("MILES_M16", MILES_M16'FORE, 5, + MILES_M16'AFT, 2); + + CHECK_FORE_AND_AFT ("SYMMETRIC_DEGREES_M7", + SYMMETRIC_DEGREES_M7'FORE, 4, + SYMMETRIC_DEGREES_M7'AFT, 1); + + CHECK_FORE_AND_AFT ("NATURAL_DEGREES_M15", + NATURAL_DEGREES_M15'FORE, 4, + NATURAL_DEGREES_M15'AFT, 2); + + CHECK_FORE_AND_AFT ("SYMMETRIC_RADIANS_M16", + SYMMETRIC_RADIANS_M16'FORE, 2, + SYMMETRIC_RADIANS_M16'AFT, 5); + + CHECK_FORE_AND_AFT ("NATURAL_RADIANS_M8", + NATURAL_RADIANS_M8'FORE, 2, + NATURAL_RADIANS_M8'AFT, 2); + + CHECK_FORE_AND_AFT ("ST_MILES_M8", ST_MILES_M8'FORE, 3, + ST_MILES_M8'AFT, 2); + + CHECK_FORE_AND_AFT ("ST_NATURAL_DEGREES_M11", + ST_NATURAL_DEGREES_M11'FORE, 4, + ST_NATURAL_DEGREES_M11'AFT, 1); + + CHECK_FORE_AND_AFT ("ST_SYMMETRIC_RADIANS_M8", + ST_SYMMETRIC_RADIANS_M8'FORE, 2, + ST_SYMMETRIC_RADIANS_M8'AFT, 2); + + RESULT; + +END C35A05D; diff --git a/gcc-4.9/gcc/testsuite/ada/acats/tests/c3/c35a05n.ada b/gcc-4.9/gcc/testsuite/ada/acats/tests/c3/c35a05n.ada new file mode 100644 index 000000000..4c1102d58 --- /dev/null +++ b/gcc-4.9/gcc/testsuite/ada/acats/tests/c3/c35a05n.ada @@ -0,0 +1,160 @@ +-- C35A05N.ADA + +-- Grant of Unlimited Rights +-- +-- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687, +-- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained +-- unlimited rights in the software and documentation contained herein. +-- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making +-- this public release, the Government intends to confer upon all +-- recipients unlimited rights equal to those held by the Government. +-- These rights include rights to use, duplicate, release or disclose the +-- released technical data and computer software in whole or in part, in +-- any manner and for any purpose whatsoever, and to have or permit others +-- to do so. +-- +-- DISCLAIMER +-- +-- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR +-- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED +-- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE +-- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE +-- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A +-- PARTICULAR PURPOSE OF SAID MATERIAL. +--* +-- CHECK THAT FOR FIXED POINT TYPES THE FORE AND AFT ATTRIBUTES YIELD +-- THE CORRECT VALUES. + +-- CASE N: BASIC TYPES THAT FIT THE CHARACTERISTICS OF DURATION'BASE, +-- FOR GENERICS. + +-- WRG 8/15/86 + +WITH REPORT; USE REPORT; +PROCEDURE C35A05N IS + + -- THE NAME OF EACH TYPE OR SUBTYPE ENDS WITH THAT TYPE'S + -- 'MANTISSA VALUE. + + TYPE LEFT_OUT_M1 IS DELTA 0.25 RANGE -0.5 .. 0.5; + TYPE LEFT_EDGE_M1 IS DELTA 0.5 RANGE -1.0 .. 1.0; + TYPE RIGHT_EDGE_M1 IS DELTA 1.0 RANGE -2.0 .. 2.0; + TYPE RIGHT_OUT_M1 IS DELTA 2.0 RANGE -4.0 .. 4.0; + TYPE MIDDLE_M2 IS DELTA 0.5 RANGE -2.0 .. 2.0; + TYPE MIDDLE_M3 IS DELTA 0.5 RANGE 0.0 .. 2.5; + TYPE MIDDLE_M15 IS DELTA 2.0 **(-6) RANGE -512.0 .. 512.0; + TYPE MIDDLE_M16 IS DELTA 2.0 **(-6) RANGE -1024.0 .. 1024.0; + TYPE LIKE_DURATION_M23 IS DELTA 0.020 RANGE -86_400.0 .. 86_400.0; + TYPE DECIMAL_M18 IS DELTA 0.1 RANGE -10_000.0 .. 10_000.0; + TYPE DECIMAL_M4 IS DELTA 100.0 RANGE -1000.0 .. 1000.0; + TYPE DECIMAL_M11 IS DELTA 0.09999 RANGE -100.0 .. 100.0; + TYPE DECIMAL2_M18 IS DELTA 0.1 RANGE -9999.0 .. 9999.0; + + ------------------------------------------------------------------- + + SUBTYPE ST_LEFT_EDGE_M6 IS MIDDLE_M15 + DELTA 2.0 ** (-6) RANGE IDENT_INT (1) * (-1.0) .. 1.0; + SUBTYPE ST_MIDDLE_M14 IS MIDDLE_M16 + DELTA 2.0 ** (-5) RANGE -512.0 .. IDENT_INT (1) * 512.0; + SUBTYPE ST_MIDDLE_M2 IS LIKE_DURATION_M23 + DELTA 0.5 RANGE -2.0 .. 2.0; + SUBTYPE ST_MIDDLE_M3 IS LIKE_DURATION_M23 + DELTA 0.5 RANGE 0.0 .. 2.5; + SUBTYPE ST_DECIMAL_M7 IS DECIMAL_M18 + DELTA 10.0 RANGE -1000.0 .. 1000.0; + SUBTYPE ST_DECIMAL_M3 IS DECIMAL_M4 + DELTA 100.0 RANGE -500.0 .. 500.0; + + ------------------------------------------------------------------- + + TYPE FORE_AND_AFT IS + RECORD + FORE, AFT : INTEGER; + END RECORD; + + GENERIC + TYPE T IS DELTA <>; + FUNCTION ATTRIBUTES RETURN FORE_AND_AFT; + + FUNCTION ATTRIBUTES RETURN FORE_AND_AFT IS + BEGIN + RETURN ( IDENT_INT (T'FORE), IDENT_INT (T'AFT) ); + END ATTRIBUTES; + + ------------------------------------------------------------------- + + PROCEDURE CHECK_ATTRIBUTES + (NAME : STRING; + ACTUAL_ATTRIBUTES, CORRECT_ATTRIBUTES : FORE_AND_AFT) IS + BEGIN + IF ACTUAL_ATTRIBUTES.FORE /= CORRECT_ATTRIBUTES.FORE THEN + FAILED ("GENERIC 'FORE FOR " & NAME & " =" & + INTEGER'IMAGE(ACTUAL_ATTRIBUTES.FORE) ); + END IF; + IF ACTUAL_ATTRIBUTES.AFT /= CORRECT_ATTRIBUTES.AFT THEN + FAILED ("GENERIC 'AFT FOR " & NAME & " =" & + INTEGER'IMAGE(ACTUAL_ATTRIBUTES.AFT ) ); + END IF; + END CHECK_ATTRIBUTES; + + ------------------------------------------------------------------- + + FUNCTION FA_LEFT_OUT_M1 IS NEW ATTRIBUTES(LEFT_OUT_M1 ); + FUNCTION FA_LEFT_EDGE_M1 IS NEW ATTRIBUTES(LEFT_EDGE_M1 ); + FUNCTION FA_RIGHT_EDGE_M1 IS NEW ATTRIBUTES(RIGHT_EDGE_M1 ); + FUNCTION FA_RIGHT_OUT_M1 IS NEW ATTRIBUTES(RIGHT_OUT_M1 ); + FUNCTION FA_MIDDLE_M2 IS NEW ATTRIBUTES(MIDDLE_M2 ); + FUNCTION FA_MIDDLE_M3 IS NEW ATTRIBUTES(MIDDLE_M3 ); + FUNCTION FA_MIDDLE_M15 IS NEW ATTRIBUTES(MIDDLE_M15 ); + FUNCTION FA_MIDDLE_M16 IS NEW ATTRIBUTES(MIDDLE_M16 ); + FUNCTION FA_LIKE_DURATION_M23 IS NEW ATTRIBUTES(LIKE_DURATION_M23); + FUNCTION FA_DECIMAL_M18 IS NEW ATTRIBUTES(DECIMAL_M18 ); + FUNCTION FA_DECIMAL_M4 IS NEW ATTRIBUTES(DECIMAL_M4 ); + FUNCTION FA_DECIMAL_M11 IS NEW ATTRIBUTES(DECIMAL_M11 ); + FUNCTION FA_DECIMAL2_M18 IS NEW ATTRIBUTES(DECIMAL2_M18 ); + FUNCTION FA_ST_LEFT_EDGE_M6 IS NEW ATTRIBUTES(ST_LEFT_EDGE_M6 ); + FUNCTION FA_ST_MIDDLE_M14 IS NEW ATTRIBUTES(ST_MIDDLE_M14 ); + FUNCTION FA_ST_MIDDLE_M2 IS NEW ATTRIBUTES(ST_MIDDLE_M2 ); + FUNCTION FA_ST_MIDDLE_M3 IS NEW ATTRIBUTES(ST_MIDDLE_M3 ); + FUNCTION FA_ST_DECIMAL_M7 IS NEW ATTRIBUTES(ST_DECIMAL_M7 ); + FUNCTION FA_ST_DECIMAL_M3 IS NEW ATTRIBUTES(ST_DECIMAL_M3 ); + +BEGIN + + TEST ("C35A05N", "CHECK THAT FOR FIXED POINT TYPES THE FORE AND " & + "AFT ATTRIBUTES YIELD THE CORRECT VALUES - " & + "BASIC TYPES, GENERICS"); + + CHECK_ATTRIBUTES ("LEFT_OUT_M1", FA_LEFT_OUT_M1, (2, 1) ); + CHECK_ATTRIBUTES ("LEFT_EDGE_M1", FA_LEFT_EDGE_M1, (2, 1) ); + CHECK_ATTRIBUTES ("RIGHT_EDGE_M1", FA_RIGHT_EDGE_M1, (2, 1) ); + CHECK_ATTRIBUTES ("RIGHT_OUT_M1", FA_RIGHT_OUT_M1, (2, 1) ); + CHECK_ATTRIBUTES ("MIDDLE_M2", FA_MIDDLE_M2, (2, 1) ); + CHECK_ATTRIBUTES ("MIDDLE_M3", FA_MIDDLE_M3, (2, 1) ); + CHECK_ATTRIBUTES ("MIDDLE_M15", FA_MIDDLE_M15, (4, 2) ); + CHECK_ATTRIBUTES ("MIDDLE_M16", FA_MIDDLE_M16, (5, 2) ); + CHECK_ATTRIBUTES ("LIKE_DURATION_M23", + FA_LIKE_DURATION_M23, (6, 2) ); + CHECK_ATTRIBUTES ("DECIMAL_M18", FA_DECIMAL_M18, (6, 1) ); + + IF FA_DECIMAL_M4.FORE /= 5 AND FA_DECIMAL_M4.FORE /= 4 THEN + FAILED ("GENERIC 'FORE FOR DECIMAL_M4 =" & + INTEGER'IMAGE(FA_DECIMAL_M4.FORE) ); + END IF; + IF FA_DECIMAL_M4.AFT /= 1 THEN + FAILED ("GENERIC 'AFT FOR DECIMAL_M4 =" & + INTEGER'IMAGE(FA_DECIMAL_M4.AFT) ); + END IF; + + CHECK_ATTRIBUTES ("DECIMAL_M11", FA_DECIMAL_M11, (4, 2) ); + CHECK_ATTRIBUTES ("DECIMAL2_M18", FA_DECIMAL2_M18, (5, 1) ); + CHECK_ATTRIBUTES ("ST_LEFT_EDGE_M6", FA_ST_LEFT_EDGE_M6, (2, 2) ); + CHECK_ATTRIBUTES ("ST_MIDDLE_M14", FA_ST_MIDDLE_M14, (4, 2) ); + CHECK_ATTRIBUTES ("ST_MIDDLE_M2", FA_ST_MIDDLE_M2, (2, 1) ); + CHECK_ATTRIBUTES ("ST_MIDDLE_M3", FA_ST_MIDDLE_M3, (2, 1) ); + CHECK_ATTRIBUTES ("ST_DECIMAL_M7", FA_ST_DECIMAL_M7, (5, 1) ); + CHECK_ATTRIBUTES ("ST_DECIMAL_M3", FA_ST_DECIMAL_M3, (4, 1) ); + + RESULT; + +END C35A05N; diff --git a/gcc-4.9/gcc/testsuite/ada/acats/tests/c3/c35a05q.ada b/gcc-4.9/gcc/testsuite/ada/acats/tests/c3/c35a05q.ada new file mode 100644 index 000000000..3a88ffb48 --- /dev/null +++ b/gcc-4.9/gcc/testsuite/ada/acats/tests/c3/c35a05q.ada @@ -0,0 +1,184 @@ +-- C35A05Q.ADA + +-- Grant of Unlimited Rights +-- +-- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687, +-- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained +-- unlimited rights in the software and documentation contained herein. +-- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making +-- this public release, the Government intends to confer upon all +-- recipients unlimited rights equal to those held by the Government. +-- These rights include rights to use, duplicate, release or disclose the +-- released technical data and computer software in whole or in part, in +-- any manner and for any purpose whatsoever, and to have or permit others +-- to do so. +-- +-- DISCLAIMER +-- +-- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR +-- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED +-- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE +-- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE +-- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A +-- PARTICULAR PURPOSE OF SAID MATERIAL. +--* +-- CHECK THAT FOR FIXED POINT TYPES THE FORE AND AFT ATTRIBUTES YIELD +-- THE CORRECT VALUES. + +-- CASE Q: TYPES TYPICAL OF APPLICATIONS USING FIXED POINT ARITHMETIC, +-- FOR GENERICS. + +-- WRG 8/20/86 + +WITH REPORT; USE REPORT; +WITH SYSTEM; USE SYSTEM; +PROCEDURE C35A05Q IS + + PI : CONSTANT := 3.14159_26535_89793_23846; + TWO_PI : CONSTANT := 2 * PI; + HALF_PI : CONSTANT := PI / 2; + + MM : CONSTANT := 23; + + -- THE NAME OF EACH TYPE OR SUBTYPE ENDS WITH THAT TYPE'S + -- 'MANTISSA VALUE. + + TYPE MICRO_ANGLE_ERROR_M15 IS + DELTA 16.0 RANGE -(2.0 ** 19) .. 2.0 ** 19; + TYPE TRACK_RANGE_M15 IS + DELTA 0.125 RANGE -(2.0 ** 12) .. 2.0 ** 12; + TYPE SECONDS_MM IS + DELTA 2.0 ** (8 - MM) RANGE -(2.0 ** 8) .. 2.0 ** 8; + TYPE RANGE_CELL_MM IS + DELTA 2.0 ** (-5) + RANGE -(2.0 ** (MM - 5) ) .. 2.0 ** (MM - 5); + + TYPE PIXEL_M10 IS DELTA 1.0 / 1024.0 RANGE 0.0 .. 1.0; + TYPE RULER_M8 IS DELTA 1.0 / 16.0 RANGE 0.0 .. 12.0; + + TYPE HOURS_M16 IS DELTA 24.0 * 2.0 ** (-15) RANGE 0.0 .. 24.0; + TYPE MILES_M16 IS DELTA 3000.0 * 2.0 ** (-15) RANGE 0.0 .. 3000.0; + + TYPE SYMMETRIC_DEGREES_M7 IS + DELTA 2.0 RANGE -180.0 .. 180.0; + TYPE NATURAL_DEGREES_M15 IS + DELTA 2.0 ** (-6) RANGE 0.0 .. 360.0; + TYPE SYMMETRIC_RADIANS_M16 IS + DELTA PI * 2.0 ** (-15) RANGE -PI .. PI; + TYPE NATURAL_RADIANS_M8 IS + DELTA TWO_PI * 2.0 ** ( -7) RANGE 0.0 .. TWO_PI; + + ------------------------------------------------------------------- + + SUBTYPE ST_MILES_M8 IS MILES_M16 + DELTA 3000.0 * 2.0 ** (-15) RANGE 0.0 .. 10.0; + SUBTYPE ST_NATURAL_DEGREES_M11 IS NATURAL_DEGREES_M15 + DELTA 0.25 RANGE 0.0 .. 360.0; + SUBTYPE ST_SYMMETRIC_RADIANS_M8 IS SYMMETRIC_RADIANS_M16 + DELTA HALF_PI * 2.0 ** (-7) RANGE -HALF_PI .. HALF_PI; + + ------------------------------------------------------------------- + + TYPE FORE_AND_AFT IS + RECORD + FORE, AFT : INTEGER; + END RECORD; + + GENERIC + TYPE T IS DELTA <>; + FUNCTION ATTRIBUTES RETURN FORE_AND_AFT; + + FUNCTION ATTRIBUTES RETURN FORE_AND_AFT IS + BEGIN + RETURN ( IDENT_INT (T'FORE), IDENT_INT (T'AFT) ); + END ATTRIBUTES; + + ------------------------------------------------------------------- + + PROCEDURE CHECK_ATTRIBUTES + (NAME : STRING; + ACTUAL_ATTRIBUTES, CORRECT_ATTRIBUTES : FORE_AND_AFT) IS + BEGIN + IF ACTUAL_ATTRIBUTES.FORE /= CORRECT_ATTRIBUTES.FORE THEN + FAILED ("GENERIC 'FORE FOR " & NAME & " =" & + INTEGER'IMAGE(ACTUAL_ATTRIBUTES.FORE) ); + END IF; + IF ACTUAL_ATTRIBUTES.AFT /= CORRECT_ATTRIBUTES.AFT THEN + FAILED ("GENERIC 'AFT FOR " & NAME & " =" & + INTEGER'IMAGE(ACTUAL_ATTRIBUTES.AFT ) ); + END IF; + END CHECK_ATTRIBUTES; + + ------------------------------------------------------------------- + + FUNCTION FA_MICRO_ANGLE_ERROR_M15 + IS NEW ATTRIBUTES(MICRO_ANGLE_ERROR_M15 ); + FUNCTION FA_TRACK_RANGE_M15 + IS NEW ATTRIBUTES(TRACK_RANGE_M15 ); + FUNCTION FA_SECONDS_MM IS NEW ATTRIBUTES(SECONDS_MM ); + FUNCTION FA_RANGE_CELL_MM + IS NEW ATTRIBUTES(RANGE_CELL_MM ); + FUNCTION FA_PIXEL_M10 IS NEW ATTRIBUTES(PIXEL_M10 ); + FUNCTION FA_RULER_M8 IS NEW ATTRIBUTES(RULER_M8 ); + FUNCTION FA_HOURS_M16 IS NEW ATTRIBUTES(HOURS_M16 ); + FUNCTION FA_MILES_M16 IS NEW ATTRIBUTES(MILES_M16 ); + FUNCTION FA_SYMMETRIC_DEGREES_M7 + IS NEW ATTRIBUTES(SYMMETRIC_DEGREES_M7 ); + FUNCTION FA_NATURAL_DEGREES_M15 + IS NEW ATTRIBUTES(NATURAL_DEGREES_M15 ); + FUNCTION FA_SYMMETRIC_RADIANS_M16 + IS NEW ATTRIBUTES(SYMMETRIC_RADIANS_M16 ); + FUNCTION FA_NATURAL_RADIANS_M8 + IS NEW ATTRIBUTES(NATURAL_RADIANS_M8 ); + FUNCTION FA_ST_MILES_M8 IS NEW ATTRIBUTES(ST_MILES_M8 ); + FUNCTION FA_ST_NATURAL_DEGREES_M11 + IS NEW ATTRIBUTES(ST_NATURAL_DEGREES_M11 ); + FUNCTION FA_ST_SYMMETRIC_RADIANS_M8 + IS NEW ATTRIBUTES(ST_SYMMETRIC_RADIANS_M8); + +BEGIN + + TEST ("C35A05Q", "CHECK THAT FOR FIXED POINT TYPES THE FORE AND " & + "AFT ATTRIBUTES YIELD THE CORRECT VALUES - " & + "TYPICAL TYPES, GENERICS"); + + CHECK_ATTRIBUTES ("MICRO_ANGLE_ERROR_M15", + FA_MICRO_ANGLE_ERROR_M15, (7, 1) ); + + CHECK_ATTRIBUTES ("TRACK_RANGE_M15", FA_TRACK_RANGE_M15, (5, 1) ); + + CHECK_ATTRIBUTES ("SECONDS_MM", FA_SECONDS_MM, (4, 5) ); + + CHECK_ATTRIBUTES ("RANGE_CELL_MM", FA_RANGE_CELL_MM, (7, 2) ); + + CHECK_ATTRIBUTES ("PIXEL_M10", FA_PIXEL_M10, (2, 4) ); + + CHECK_ATTRIBUTES ("RULER_M8", FA_RULER_M8, (3, 2) ); + + CHECK_ATTRIBUTES ("HOURS_M16", FA_HOURS_M16, (3, 4) ); + + CHECK_ATTRIBUTES ("MILES_M16", FA_MILES_M16, (5, 2) ); + + CHECK_ATTRIBUTES ("SYMMETRIC_DEGREES_M7", + FA_SYMMETRIC_DEGREES_M7, (4, 1) ); + + CHECK_ATTRIBUTES ("NATURAL_DEGREES_M15", + FA_NATURAL_DEGREES_M15, (4, 2) ); + + CHECK_ATTRIBUTES ("SYMMETRIC_RADIANS_M16", + FA_SYMMETRIC_RADIANS_M16, (2, 5) ); + + CHECK_ATTRIBUTES ("NATURAL_RADIANS_M8", + FA_NATURAL_RADIANS_M8, (2, 2) ); + + CHECK_ATTRIBUTES ("ST_MILES_M8", FA_ST_MILES_M8, (3, 2) ); + + CHECK_ATTRIBUTES ("ST_NATURAL_DEGREES_M11", + FA_ST_NATURAL_DEGREES_M11, (4, 1) ); + + CHECK_ATTRIBUTES ("ST_SYMMETRIC_RADIANS_M8", + FA_ST_SYMMETRIC_RADIANS_M8, (2, 2) ); + + RESULT; + +END C35A05Q; diff --git a/gcc-4.9/gcc/testsuite/ada/acats/tests/c3/c35a07a.ada b/gcc-4.9/gcc/testsuite/ada/acats/tests/c3/c35a07a.ada new file mode 100644 index 000000000..ae7baf6fa --- /dev/null +++ b/gcc-4.9/gcc/testsuite/ada/acats/tests/c3/c35a07a.ada @@ -0,0 +1,129 @@ +-- C35A07A.ADA + +-- Grant of Unlimited Rights +-- +-- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687, +-- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained +-- unlimited rights in the software and documentation contained herein. +-- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making +-- this public release, the Government intends to confer upon all +-- recipients unlimited rights equal to those held by the Government. +-- These rights include rights to use, duplicate, release or disclose the +-- released technical data and computer software in whole or in part, in +-- any manner and for any purpose whatsoever, and to have or permit others +-- to do so. +-- +-- DISCLAIMER +-- +-- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR +-- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED +-- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE +-- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE +-- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A +-- PARTICULAR PURPOSE OF SAID MATERIAL. +--* +-- CHECK THAT FOR FIXED POINT TYPES THE FIRST AND LAST ATTRIBUTES YIELD +-- CORRECT VALUES. + +-- CASE A: BASIC TYPES THAT FIT THE CHARACTERISTICS OF DURATION'BASE. + +-- WRG 8/25/86 +-- PWN 01/31/95 REMOVED INCONSISTENCIES WITH ADA 9X. + +WITH REPORT; USE REPORT; +PROCEDURE C35A07A IS + + -- THE NAME OF EACH TYPE OR SUBTYPE ENDS WITH THAT TYPE'S + -- 'MANTISSA VALUE. + + TYPE MIDDLE_M3 IS DELTA 0.5 RANGE 0.0 .. 2.5; + TYPE MIDDLE_M15 IS DELTA 2.0 **(-6) RANGE -512.0 .. 512.0; + TYPE LIKE_DURATION_M23 IS DELTA 0.020 RANGE -86_400.0 .. 86_400.0; + TYPE DECIMAL_M18 IS DELTA 0.1 RANGE -10_000.0 .. 10_000.0; + TYPE DECIMAL_M4 IS DELTA 100.0 RANGE -1000.0 .. 1000.0; + -- LARGEST MODEL NUMBER IS 960.0. + + ------------------------------------------------------------------- + + SUBTYPE ST_LEFT_EDGE_M6 IS MIDDLE_M15 + DELTA 2.0 ** (-6) RANGE IDENT_INT (1) * (-1.0) .. 1.0; + SUBTYPE ST_MIDDLE_M3 IS LIKE_DURATION_M23 + DELTA 0.5 RANGE 0.0 .. 2.5; + SUBTYPE ST_DECIMAL_M7 IS DECIMAL_M18 + DELTA 10.0 RANGE -1000.0 .. 1000.0; + -- LARGEST MODEL NUMBER IS 1016.0. + SUBTYPE ST_DECIMAL_M3 IS DECIMAL_M4 + DELTA 100.0 RANGE -500.0 .. 500.0; + -- LARGEST MODEL NUMBER IS 448.0. + SUBTYPE ST_MIDDLE_M15 IS MIDDLE_M15 + RANGE 6.0 .. 3.0; + +BEGIN + + TEST ("C35A07A", "CHECK THAT FOR FIXED POINT TYPES THE FIRST " & + "AND LAST ATTRIBUTES YIELD CORRECT VALUES - " & + "BASIC TYPES"); + + ------------------------------------------------------------------- + + + IF MIDDLE_M3'FIRST /= IDENT_INT (1) * 0.0 THEN + FAILED ("MIDDLE_M3'FIRST /= 0.0"); + END IF; + IF MIDDLE_M3'LAST /= IDENT_INT (1) * 2.5 THEN + FAILED ("MIDDLE_M3'LAST /= 2.5"); + END IF; + + ------------------------------------------------------------------- + + + IF LIKE_DURATION_M23'FIRST /= IDENT_INT (1) * (-86_400.0) THEN + FAILED ("LIKE_DURATION_M23'FIRST /= -86_400.0"); + END IF; + IF LIKE_DURATION_M23'LAST /= IDENT_INT (1) * 86_400.0 THEN + FAILED ("LIKE_DURATION_M23'LAST /= 86_400.0"); + END IF; + + ------------------------------------------------------------------- + + IF DECIMAL_M18'FIRST /= IDENT_INT (1) * (-10_000.0) THEN + FAILED ("DECIMAL_M18'FIRST /= -10_000.0"); + END IF; + IF DECIMAL_M18'LAST /= IDENT_INT (1) * 10_000.0 THEN + FAILED ("DECIMAL_M18'LAST /= 10_000.0"); + END IF; + + ------------------------------------------------------------------- + + + IF ST_MIDDLE_M3'FIRST /= IDENT_INT (1) * 0.0 THEN + FAILED ("ST_MIDDLE_M3'FIRST /= 0.0"); + END IF; + IF ST_MIDDLE_M3'LAST /= IDENT_INT (1) * 2.5 THEN + FAILED ("ST_MIDDLE_M3'LAST /= 2.5"); + END IF; + + ------------------------------------------------------------------- + + IF ST_DECIMAL_M7'FIRST /= IDENT_INT (1) * (-1000.0) THEN + FAILED ("ST_DECIMAL_M7'FIRST /= -1000.0"); + END IF; + IF ST_DECIMAL_M7'LAST /= IDENT_INT (1) * 1000.0 THEN + FAILED ("ST_DECIMAL_M7'LAST /= 1000.0"); + END IF; + + ------------------------------------------------------------------- + + + IF ST_MIDDLE_M15'FIRST /= IDENT_INT (1) * 6.0 THEN + FAILED ("ST_MIDDLE_M15'FIRST /= 6.0"); + END IF; + IF ST_MIDDLE_M15'LAST /= IDENT_INT (1) * 3.0 THEN + FAILED ("ST_MIDDLE_M15'LAST /= 3.0"); + END IF; + + ------------------------------------------------------------------- + + RESULT; + +END C35A07A; diff --git a/gcc-4.9/gcc/testsuite/ada/acats/tests/c3/c35a07d.ada b/gcc-4.9/gcc/testsuite/ada/acats/tests/c3/c35a07d.ada new file mode 100644 index 000000000..1a293cc83 --- /dev/null +++ b/gcc-4.9/gcc/testsuite/ada/acats/tests/c3/c35a07d.ada @@ -0,0 +1,191 @@ +-- C35A07D.ADA + +-- Grant of Unlimited Rights +-- +-- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687, +-- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained +-- unlimited rights in the software and documentation contained herein. +-- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making +-- this public release, the Government intends to confer upon all +-- recipients unlimited rights equal to those held by the Government. +-- These rights include rights to use, duplicate, release or disclose the +-- released technical data and computer software in whole or in part, in +-- any manner and for any purpose whatsoever, and to have or permit others +-- to do so. +-- +-- DISCLAIMER +-- +-- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR +-- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED +-- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE +-- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE +-- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A +-- PARTICULAR PURPOSE OF SAID MATERIAL. +--* +-- CHECK THAT FOR FIXED POINT TYPES THE FIRST AND LAST ATTRIBUTES YIELD +-- CORRECT VALUES. + +-- CASE D: TYPES TYPICAL OF APPLICATIONS USING FIXED POINT ARITHMETIC. + +-- WRG 8/25/86 +-- PWN 01/31/95 REMOVED INCONSISTENCIES WITH ADA 9X. + +WITH REPORT; USE REPORT; +WITH SYSTEM; USE SYSTEM; +PROCEDURE C35A07D IS + + PI : CONSTANT := 3.14159_26535_89793_23846; + TWO_PI : CONSTANT := 2 * PI; + HALF_PI : CONSTANT := PI / 2; + + MM : CONSTANT := MAX_MANTISSA; + + -- THE NAME OF EACH TYPE OR SUBTYPE ENDS WITH THAT TYPE'S + -- 'MANTISSA VALUE. + + TYPE PIXEL_M10 IS DELTA 1.0 / 1024.0 RANGE 0.0 .. 1.0; + TYPE RULER_M8 IS DELTA 1.0 / 16.0 RANGE 0.0 .. 12.0; + + TYPE HOURS_M16 IS DELTA 24.0 * 2.0 ** (-15) RANGE 0.0 .. 24.0; + TYPE MILES_M16 IS DELTA 3000.0 * 2.0 ** (-15) RANGE 0.0 .. 3000.0; + + TYPE SYMMETRIC_DEGREES_M7 IS + DELTA 2.0 RANGE -180.0 .. 180.0; + TYPE NATURAL_DEGREES_M15 IS + DELTA 2.0 ** (-6) RANGE 0.0 .. 360.0; + TYPE SYMMETRIC_RADIANS_M16 IS + DELTA PI * 2.0 ** (-15) RANGE -PI .. PI; + -- 'SMALL = 2.0 ** (-14) = 0.00006_10351_5625. + TYPE NATURAL_RADIANS_M8 IS + DELTA TWO_PI * 2.0 ** ( -7) RANGE 0.0 .. TWO_PI; + -- 'SMALL = 2.0 ** ( -5) = 0.03125. + + ------------------------------------------------------------------- + + SUBTYPE ST_MILES_M8 IS MILES_M16 + DELTA 3000.0 * 2.0 ** (-15) RANGE 0.0 .. 10.0; + SUBTYPE ST_NATURAL_DEGREES_M11 IS NATURAL_DEGREES_M15 + DELTA 0.25 RANGE 0.0 .. 360.0; + SUBTYPE ST_SYMMETRIC_RADIANS_M8 IS SYMMETRIC_RADIANS_M16 + DELTA HALF_PI * 2.0 ** (-7) RANGE -HALF_PI .. HALF_PI; + -- 'SMALL = 2.0 ** ( -7) = 0.00781_25. + +BEGIN + + TEST ("C35A07D", "CHECK THAT FOR FIXED POINT TYPES THE FIRST " & + "AND LAST ATTRIBUTES YIELD CORRECT VALUES - " & + "TYPICAL TYPES"); + + ------------------------------------------------------------------- + + + IF PIXEL_M10'FIRST /= IDENT_INT (1) * 0.0 THEN + FAILED ("PIXEL_M10'FIRST /= 0.0"); + END IF; + + ------------------------------------------------------------------- + + IF RULER_M8'FIRST /= IDENT_INT (1) * 0.0 THEN + FAILED ("RULER_M8'FIRST /= 0.0"); + END IF; + IF RULER_M8'LAST /= IDENT_INT (1) * 12.0 THEN + FAILED ("RULER_M8'LAST /= 12.0"); + END IF; + + ------------------------------------------------------------------- + + IF HOURS_M16'FIRST /= IDENT_INT (1) * 0.0 THEN + FAILED ("HOURS_M16'FIRST /= 0.0"); + END IF; + IF HOURS_M16'LAST /= IDENT_INT (1) * 24.0 THEN + FAILED ("HOURS_M16'LAST /= 24.0"); + END IF; + + ------------------------------------------------------------------- + + IF MILES_M16'FIRST /= IDENT_INT (1) * 0.0 THEN + FAILED ("MILES_M16'FIRST /= 0.0"); + END IF; + IF MILES_M16'LAST /= IDENT_INT (1) * 3000.0 THEN + FAILED ("MILES_M16'LAST /= 3000.0"); + END IF; + + ------------------------------------------------------------------- + + IF SYMMETRIC_DEGREES_M7'FIRST /= IDENT_INT (1) * (-180.0) THEN + FAILED ("SYMMETRIC_DEGREES_M7'FIRST /= -180.0"); + END IF; + IF SYMMETRIC_DEGREES_M7'LAST /= IDENT_INT (1) * 180.0 THEN + FAILED ("SYMMETRIC_DEGREES_M7'LAST /= 180.0"); + END IF; + + ------------------------------------------------------------------- + + IF NATURAL_DEGREES_M15'FIRST /= IDENT_INT (1) * 0.0 THEN + FAILED ("NATURAL_DEGREES_M15'FIRST /= 0.0"); + END IF; + IF NATURAL_DEGREES_M15'LAST /= IDENT_INT (1) * 360.0 THEN + FAILED ("NATURAL_DEGREES_M15'LAST /= 360.0"); + END IF; + + ------------------------------------------------------------------- + + -- PI IS IN 3.0 + 2319 * 'SMALL .. 3.0 + 2320 * 'SMALL. + IF SYMMETRIC_RADIANS_M16'FIRST NOT IN + -3.14160_15625 .. -3.14154_05273_4375 THEN + FAILED ("SYMMETRIC_RADIANS_M16'FIRST NOT IN " & + "-3.14160_15625 .. -3.14154_05273_4375"); + END IF; + IF SYMMETRIC_RADIANS_M16'LAST NOT IN + 3.14154_05273_4375 .. 3.14160_15625 THEN + FAILED ("SYMMETRIC_RADIANS_M16'LAST NOT IN " & + "3.14154_05273_4375 .. 3.14160_15625"); + END IF; + + ------------------------------------------------------------------- + + IF NATURAL_RADIANS_M8'FIRST /= IDENT_INT (1) * 0.0 THEN + FAILED ("NATURAL_RADIANS_M8'FIRST /= 0.0"); + END IF; + -- TWO_PI IS IN 201 * 'SMALL .. 202 * 'SMALL. + IF NATURAL_RADIANS_M8'LAST NOT IN 6.28125 .. 6.3125 THEN + FAILED ("NATURAL_RADIANS_M8'LAST NOT IN 6.28125 .. 6.3125"); + END IF; + + ------------------------------------------------------------------- + + IF ST_MILES_M8'FIRST /= IDENT_INT (1) * 0.0 THEN + FAILED ("ST_MILES_M8'FIRST /= 0.0"); + END IF; + IF ST_MILES_M8'LAST /= IDENT_INT (1) * 10.0 THEN + FAILED ("ST_MILES_M8'LAST /= 10.0"); + END IF; + + ------------------------------------------------------------------- + + IF ST_NATURAL_DEGREES_M11'FIRST /= IDENT_INT (1) * 0.0 THEN + FAILED ("ST_NATURAL_DEGREES_M11'FIRST /= 0.0"); + END IF; + IF ST_NATURAL_DEGREES_M11'LAST /= IDENT_INT (1) * 360.0 THEN + FAILED ("ST_NATURAL_DEGREES_M11'LAST /= 360.0"); + END IF; + + ------------------------------------------------------------------- + + -- HALF_PI IS IN 201 * 'SMALL .. 202 * 'SMALL. + IF ST_SYMMETRIC_RADIANS_M8'FIRST NOT IN + -1.57812_5 .. -1.57031_25 THEN + FAILED ("ST_SYMMETRIC_RADIANS_M8'FIRST NOT IN " & + "-1.57812_5 .. -1.57031_25"); + END IF; + IF ST_SYMMETRIC_RADIANS_M8'LAST NOT IN + 1.57031_25 .. 1.57812_5 THEN + FAILED ("ST_SYMMETRIC_RADIANS_M8'LAST NOT IN " & + "1.57031_25 .. 1.57812_5"); + END IF; + + ------------------------------------------------------------------- + + RESULT; + +END C35A07D; diff --git a/gcc-4.9/gcc/testsuite/ada/acats/tests/c3/c35a08b.ada b/gcc-4.9/gcc/testsuite/ada/acats/tests/c3/c35a08b.ada new file mode 100644 index 000000000..1750bfa12 --- /dev/null +++ b/gcc-4.9/gcc/testsuite/ada/acats/tests/c3/c35a08b.ada @@ -0,0 +1,91 @@ +-- C35A08B.ADA + +-- Grant of Unlimited Rights +-- +-- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687, +-- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained +-- unlimited rights in the software and documentation contained herein. +-- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making +-- this public release, the Government intends to confer upon all +-- recipients unlimited rights equal to those held by the Government. +-- These rights include rights to use, duplicate, release or disclose the +-- released technical data and computer software in whole or in part, in +-- any manner and for any purpose whatsoever, and to have or permit others +-- to do so. +-- +-- DISCLAIMER +-- +-- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR +-- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED +-- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF 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 MULTIPLICATION AND DIVISION OPERATORS FOR TWO +-- FIXED POINT OPERANDS ARE DECLARED IN STANDARD AND ARE DIRECTLY +-- VISIBLE. + +-- HISTORY: +-- BCB 01/21/88 CREATED ORIGINAL TEST. + +WITH REPORT; USE REPORT; + +PROCEDURE C35A08B IS + + PACKAGE P IS + TYPE T1 IS DELTA 2.0**(-4) RANGE -100.0 .. 100.0; + TYPE T2 IS DELTA 2.0**(-4) RANGE -100.0 .. 100.0; + END P; + USE P; + + X1 : P.T1 := 6.0; + X2 : P.T1 := 2.0; + X3 : P.T1; + X4 : P.T1; + X5 : P.T1; + X6 : P.T1; + + X7 : P.T2 := 2.0; + + FUNCTION IDENT_FIXED(X : P.T1) RETURN P.T1 IS + BEGIN + RETURN X * IDENT_INT(1); + END IDENT_FIXED; + +BEGIN + TEST ("C35A08B", "CHECK THAT THE MULTIPLICATION AND DIVISION " & + "OPERATORS FOR TWO FIXED POINT OPERANDS ARE " & + "DECLARED IN STANDARD AND ARE DIRECTLY VISIBLE"); + + X3 := P.T1 (X1 * X2); + X4 := P.T1 (X1 / X2); + + X5 := P.T1 (STANDARD."*" (X1,X2)); + X6 := P.T1 (STANDARD."/" (X1,X2)); + + IF X3 /= IDENT_FIXED (12.0) THEN + FAILED ("IMPROPER VALUE FOR FIXED POINT MULTIPLICATION - 1"); + END IF; + + IF X4 /= IDENT_FIXED (3.0) THEN + FAILED ("IMPROPER VALUE FOR FIXED POINT DIVISION - 1"); + END IF; + + X3 := P.T1 (X1 * X7); + X4 := P.T1 (X1 / X7); + + X5 := P.T1 (STANDARD."*" (X1,X7)); + X6 := P.T1 (STANDARD."/" (X1,X7)); + + IF X3 /= IDENT_FIXED (12.0) THEN + FAILED ("IMPROPER VALUE FOR FIXED POINT MULTIPLICATION - 2"); + END IF; + + IF X4 /= IDENT_FIXED (3.0) THEN + FAILED ("IMPROPER VALUE FOR FIXED POINT DIVISION - 2"); + END IF; + + RESULT; +END C35A08B; diff --git a/gcc-4.9/gcc/testsuite/ada/acats/tests/c3/c360002.a b/gcc-4.9/gcc/testsuite/ada/acats/tests/c3/c360002.a new file mode 100644 index 000000000..95cb3ef07 --- /dev/null +++ b/gcc-4.9/gcc/testsuite/ada/acats/tests/c3/c360002.a @@ -0,0 +1,268 @@ +-- C360002.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 modular types may be used as array indices. +-- +-- Check that if aliased appears in the component_definition of an +-- array_type that each component of the array is aliased. +-- +-- Check that references to aliased array objects produce correct +-- results, and that out-of-bounds indexing correctly produces +-- Constraint_Error. +-- +-- TEST DESCRIPTION: +-- This test defines several array types and subtypes indexed by modular +-- types; some aliased some not, some with aliased components, some not. +-- +-- It then checks that assignments move the correct data. +-- +-- +-- CHANGE HISTORY: +-- 28 SEP 95 SAIC Initial version +-- 23 APR 96 SAIC Doc fixes, fixed constrained/unconstrained conflict +-- 13 FEB 97 PWB.CTA Removed illegal declarations and affected code +--! + +------------------------------------------------------------------- C360002 + +with Report; + +procedure C360002 is + + Verbose : Boolean := Report.Ident_Bool( False ); + + type Mod_128 is mod 128; + + function Ident_128( I: Integer ) return Mod_128 is + begin + return Mod_128( Report.Ident_Int( I ) ); + end Ident_128; + + type Unconstrained_Array + is array( Mod_128 range <> ) of Integer; + + type Unconstrained_Array_Aliased + is array( Mod_128 range <> ) of aliased Integer; + + type Access_All_Unconstrained_Array + is access all Unconstrained_Array; + + type Access_All_Unconstrained_Array_Aliased + is access all Unconstrained_Array_Aliased; + + subtype Array_01_10 + is Unconstrained_Array(01..10); + + subtype Array_11_20 + is Unconstrained_Array(11..20); + + subtype Array_Aliased_01_10 + is Unconstrained_Array_Aliased(01..10); + + subtype Array_Aliased_11_20 + is Unconstrained_Array_Aliased(11..20); + + subtype Access_All_01_10_Array + is Access_All_Unconstrained_Array(01..10); + + subtype Access_All_01_10_Array_Aliased + is Access_All_Unconstrained_Array_Aliased(01..10); + + subtype Access_All_11_20_Array + is Access_All_Unconstrained_Array(11..20); + + subtype Access_All_11_20_Array_Aliased + is Access_All_Unconstrained_Array_Aliased(11..20); + + +-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- + + -- these 'filler' functions create unique values for every element that + -- is used and/or tested in this test. + + Well_Bottom : Integer := 0; + + function Filler( Size : Mod_128 ) return Unconstrained_Array is + It : Unconstrained_Array( 0..Size-1 ); + begin + for Eyes in It'Range loop + It(Eyes) := Integer( Eyes ) + Well_Bottom; + end loop; + Well_Bottom := Well_Bottom + It'Length; + return It; + end Filler; + + function Filler( Size : Mod_128 ) return Unconstrained_Array_Aliased is + It : Unconstrained_Array_Aliased( 0..Size-1 ); + begin + for Ayes in It'Range loop + It(Ayes) := Integer( Ayes ) + Well_Bottom; + end loop; + Well_Bottom := Well_Bottom + It'Length; + return It; + end Filler; + +-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- + + An_Integer : Integer; + + type AAI is access all Integer; + + An_Integer_Access : AAI; + + Array_Item_01_10 : Array_01_10 := Filler(10); -- 0..9 + + Array_Item_11_20 : Array_11_20 := Filler(10); -- 10..19 (sliding) + + Array_Aliased_Item_01_10 : Array_Aliased_01_10 := Filler(10); -- 20..29 + + Array_Aliased_Item_11_20 : Array_Aliased_11_20 := Filler(10); -- 30..39 + + Aliased_Array_Item_01_10 : aliased Array_01_10 := Filler(10); -- 40..49 + + Aliased_Array_Item_11_20 : aliased Array_11_20 := Filler(10); -- 50..59 + + Aliased_Array_Aliased_Item_01_10 : aliased Array_Aliased_01_10 + := Filler(10); -- 60..69 + + Aliased_Array_Aliased_Item_11_20 : aliased Array_Aliased_11_20 + := Filler(10); -- 70..79 + + Check_Item : Access_All_Unconstrained_Array; + + Check_Aliased_Item : Access_All_Unconstrained_Array_Aliased; + +-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- + + procedure Fail( Message : String; CI, SB : Integer ) is + begin + Report.Failed("Wrong value passed " & Message); + if Verbose then + Report.Comment("got" & Integer'Image(CI) & + " should be" & Integer'Image(SB) ); + end if; + end Fail; + + procedure Check_Array_01_10( Checked_Item : Array_01_10; + Low_SB : Integer ) is + begin + for Index in Checked_Item'Range loop + if (Checked_Item(Index) /= (Low_SB +Integer(Index)-1)) then + Fail("unaliased 1..10", Checked_Item(Index), + (Low_SB +Integer(Index)-1)); + end if; + end loop; + end Check_Array_01_10; + + procedure Check_Array_11_20( Checked_Item : Array_11_20; + Low_SB : Integer ) is + begin + for Index in Checked_Item'Range loop + if (Checked_Item(Index) /= (Low_SB +Integer(Index)-11)) then + Fail("unaliased 11..20", Checked_Item(Index), + (Low_SB +Integer(Index)-11)); + end if; + end loop; + end Check_Array_11_20; + + procedure Check_Single_Integer( The_Integer, SB : Integer; + Message : String ) is + begin + if The_Integer /= SB then + Report.Failed("Wrong integer value for " & Message ); + end if; + end Check_Single_Integer; + +-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- + +begin -- Main test procedure. + + Report.Test ("C360002", "Check that modular types may be used as array " & + "indices. Check that if aliased appears in " & + "the component_definition of an array_type that " & + "each component of the array is aliased. Check " & + "that references to aliased array objects " & + "produce correct results, and that out of bound " & + "references to aliased objects correctly " & + "produce Constraint_Error" ); + -- start with checks that the Filler assignments produced the expected + -- result. This is a "case 0" test to check that nothing REALLY surprising + -- is happening + + Check_Array_01_10( Array_Item_01_10, 0 ); + Check_Array_11_20( Array_Item_11_20, 10 ); + + -- check that having the variable aliased makes no difference + Check_Array_01_10( Aliased_Array_Item_01_10, 40 ); + Check_Array_11_20( Aliased_Array_Item_11_20, 50 ); + + -- now check that conversion between array types where the only + -- difference in the definitions is that the components are aliased works + + Check_Array_01_10( Unconstrained_Array( Array_Aliased_Item_01_10 ), 20 ); + Check_Array_11_20( Unconstrained_Array( Array_Aliased_Item_11_20 ), 30 ); + + -- check that conversion of an aliased object with aliased components + -- also works + + Check_Array_01_10( Unconstrained_Array( Aliased_Array_Aliased_Item_01_10 ), + 60 ); + Check_Array_11_20( Unconstrained_Array( Aliased_Array_Aliased_Item_11_20 ), + 70 ); + + -- check that the bounds will slide + + Check_Array_01_10( Array_01_10( Array_Item_11_20 ), 10 ); + Check_Array_11_20( Array_11_20( Array_Item_01_10 ), 0 ); + + -- point at some of the components and check them + + An_Integer_Access := Array_Aliased_Item_01_10(5)'Access; + + Check_Single_Integer( An_Integer_Access.all, 24, + "Aliased component 'Access"); + + An_Integer_Access := Aliased_Array_Aliased_Item_01_10(7)'Access; + + Check_Single_Integer( An_Integer_Access.all, 66, + "Aliased Aliased component 'Access"); + + -- check some assignments + + Array_Item_01_10 := Aliased_Array_Item_01_10; + Check_Array_01_10( Array_Item_01_10, 40 ); + + Aliased_Array_Item_01_10 := Aliased_Array_Item_11_20(11..20); + Check_Array_01_10( Aliased_Array_Item_01_10, 50 ); + + Aliased_Array_Aliased_Item_11_20(11..20) + := Aliased_Array_Aliased_Item_01_10; + Check_Array_11_20( Unconstrained_Array( Aliased_Array_Aliased_Item_11_20 ), + 60 ); + + Report.Result; + +end C360002; diff --git a/gcc-4.9/gcc/testsuite/ada/acats/tests/c3/c36104a.ada b/gcc-4.9/gcc/testsuite/ada/acats/tests/c3/c36104a.ada new file mode 100644 index 000000000..4cdaccd0b --- /dev/null +++ b/gcc-4.9/gcc/testsuite/ada/acats/tests/c3/c36104a.ada @@ -0,0 +1,359 @@ +-- C36104A.ADA + +-- Grant of Unlimited Rights +-- +-- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687, +-- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained +-- unlimited rights in the software and documentation contained herein. +-- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making +-- this public release, the Government intends to confer upon all +-- recipients unlimited rights equal to those held by the Government. +-- These rights include rights to use, duplicate, release or disclose the +-- released technical data and computer software in whole or in part, in +-- any manner and for any purpose whatsoever, and to have or permit others +-- to do so. +-- +-- DISCLAIMER +-- +-- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR +-- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED +-- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE +-- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE +-- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A +-- PARTICULAR PURPOSE OF SAID MATERIAL. +--* +-- CHECK THAT CONSTRAINT_ERROR IS RAISED OR NOT, AS APPROPRIATE, +-- DURING DISCRETE_RANGE ELABORATIONS/EVALUATIONS IN LOOPS, +-- ARRAY_TYPE_DEFINITIONS, ARRAY AGGREGATES, SLICES, +-- AND INDEX CONSTRAINTS IN OBJECT AND TYPE DECLARATIONS, +-- WHERE AN EXPLICIT (SUB)TYPE IS INCLUDED IN EACH DISCRETE_RANGE. +-- MEMBERSHIP OPERATORS ARE CHECKED HERE, ALSO, TO ENSURE THAT +-- EXCEPTIONS ARE NOT RAISED FOR NULL RANGES. +-- ONLY STATIC CASES ARE CHECKED HERE. + +-- DAT 2/3/81 +-- JRK 2/25/81 +-- VKG 1/21/83 +-- L.BROWN 7/15/86 1) ADDED ACCESS TYPES. +-- 2) DELETED "NULL INDEX RANGES, CONSTRAINT_ERROR +-- RAISED" SECTION. +-- 3) DELETED ANY MENTION OF CASE STATEMENT CHOICES +-- AND VARIANT CHOICES IN THE ABOVE COMMENT. +-- EDS 7/16/98 AVOID OPTIMIZATION + +WITH REPORT; +PROCEDURE C36104A IS + + USE REPORT; + + TYPE WEEK IS (SUN, MON, TUE, WED, THU, FRI, SAT); + TYPE WEEK_ARRAY IS ARRAY (WEEK RANGE <>) OF WEEK; + SUBTYPE WORK_WEEK IS WEEK RANGE MON .. FRI; + SUBTYPE MID_WEEK IS WORK_WEEK RANGE TUE .. THU; + + TYPE INT_10 IS NEW INTEGER RANGE -10 .. 10; + TYPE I_10 IS NEW INT_10; + SUBTYPE I_5 IS I_10 RANGE -5 .. 5; + TYPE I_5_ARRAY IS ARRAY (I_5 RANGE <>) OF I_5; + +BEGIN + TEST ("C36104A", "CONSTRAINT_ERROR IS RAISED OR NOT IN STATIC " + & "DISCRETE_RANGES WITH EXPLICIT TYPE_MARKS"); + + -- NON-NULL RANGES, CONSTRAINT_ERROR RAISED. + + BEGIN + DECLARE + TYPE A IS ARRAY (I_5 RANGE 0 .. 6) OF I_5; + -- ABOVE DECLARATION RAISES CONSTRAINT_ERROR. + BEGIN + DECLARE + -- DEFINE AN OBJECT OF TYPE A AND USE IT TO AVOID + -- OPTIMIZATION OF SUBTYPE + A1 : A := (OTHERS => I_5(IDENT_INT(1))); + BEGIN + FAILED ("CONSTRAINT_ERROR NOT RAISED 1 " & + I_5'IMAGE(A1(1)) ); --USE A1 + END; + EXCEPTION + --MAKE SURE THAT CONSTRAINT_ERROR FROM ABOVE STATEMENTS + --REPORT FAILED. + WHEN OTHERS => FAILED ("UNHANDLED EXCEPTION RAISED 1"); + END; + EXCEPTION + WHEN CONSTRAINT_ERROR => NULL; + WHEN OTHERS => + FAILED ("WRONG EXCEPTION RAISED 1"); + END; + + BEGIN + FOR I IN MID_WEEK RANGE MON .. MON LOOP + FAILED ("CONSTRAINT_ERROR NOT RAISED 3"); + END LOOP; + FAILED ("CONSTRAINT_ERROR NOT RAISED 3"); + EXCEPTION + WHEN CONSTRAINT_ERROR => NULL; + WHEN OTHERS => + FAILED ("WRONG EXCEPTION RAISED 3"); + END; + + BEGIN + DECLARE + TYPE P IS ACCESS I_5_ARRAY (I_5 RANGE 0 .. 6); + -- ABOVE DECLARATION RAISES CONSTRAINT_ERROR. + BEGIN + DECLARE + TYPE PA IS NEW P; + -- DEFINE AN OBJECT OF TYPE PA AND USE IT TO AVOID + -- OPTIMIZATION OF TYPE + PA1 : PA := NEW I_5_ARRAY'(0 .. I_5(IDENT_INT(6)) => + I_5(IDENT_INT(1))); + BEGIN + FAILED ("CONSTRAINT_ERROR NOT RAISED 4 " & + I_5'IMAGE(PA1(1))); --USE PA1 + END; + EXCEPTION + WHEN OTHERS => FAILED ("UNHANDLED EXCEPTION RAISED 4"); + END; + EXCEPTION + WHEN CONSTRAINT_ERROR => NULL; + WHEN OTHERS => + FAILED ("WRONG EXCEPTION RAISED 4"); + END; + + DECLARE + W : WEEK_ARRAY (MID_WEEK); + BEGIN + W := (MID_WEEK RANGE MON .. WED => WED); + -- CONSTRAINT_ERROR RAISED. + FAILED ("CONSTRAINT_ERROR NOT RAISED 7 " & + MID_WEEK'IMAGE(W(WED))); --USE W + EXCEPTION + WHEN CONSTRAINT_ERROR => NULL; + WHEN OTHERS => + FAILED ("WRONG EXCEPTION RAISED 7"); + END; + + DECLARE + W : WEEK_ARRAY (WORK_WEEK); + BEGIN + W := (W'RANGE => WED); -- OK. + W (MON .. WED) := W (MID_WEEK RANGE MON .. WED); -- EXCEPTION. + FAILED ("CONSTRAINT_ERROR NOT RAISED 8 " & + MID_WEEK'IMAGE(W(WED))); --USE W + EXCEPTION + WHEN CONSTRAINT_ERROR => NULL; + WHEN OTHERS => + FAILED ("WRONG EXCEPTION RAISED 8"); + END; + + BEGIN + DECLARE + W : WEEK_ARRAY (MID_WEEK RANGE MON .. FRI); + -- ELABORATION OF ABOVE RAISES CONSTRAINT_ERROR. + BEGIN + W := (W'RANGE => WED); -- OK. + FAILED ("CONSTRAINT_ERROR NOT RAISED 9 " & + MID_WEEK'IMAGE(W(WED))); --USE W + EXCEPTION + WHEN OTHERS => FAILED ("UNHANDLED EXCEPTION RAISED 9"); + END; + EXCEPTION + WHEN CONSTRAINT_ERROR => NULL; + WHEN OTHERS => + FAILED ("WRONG EXCEPTION RAISED 9"); + END; + + BEGIN + DECLARE + TYPE W IS NEW WEEK_ARRAY (MID_WEEK RANGE SUN .. TUE); + -- RAISES CONSTRAINT_ERROR. + BEGIN + DECLARE + W1 : W := (OTHERS => WED); + BEGIN + FAILED ("CONSTRAINT_ERROR NOT RAISED 10 " & + MID_WEEK'IMAGE(W1(WED))); --USE W1 + END; + EXCEPTION + WHEN OTHERS => FAILED ("UNHANDLED EXCEPTION RAISED 10"); + END; + EXCEPTION + WHEN CONSTRAINT_ERROR => NULL; + WHEN OTHERS => + FAILED ("WRONG EXCEPTION RAISED 10"); + END; + + BEGIN + DECLARE + SUBTYPE W IS WEEK_ARRAY (MID_WEEK RANGE MON .. WED); + -- RAISES CONSTRAINT_ERROR. + BEGIN + DECLARE + W1 : W := (OTHERS => (WED)); + BEGIN + FAILED ("CONSTRAINT_ERROR NOT RAISED 8 " & + MID_WEEK'IMAGE(W1(WED))); --USE W1 + END; + EXCEPTION + WHEN OTHERS => FAILED ("UNHANDLED EXCEPTION RAISED 8"); + END; + EXCEPTION + WHEN CONSTRAINT_ERROR => NULL; + WHEN OTHERS => + FAILED ("WRONG EXCEPTION RAISED 11"); + END; + + -- NULL DISCRETE/INDEX RANGES, EXCEPTION NOT RAISED. + + BEGIN + DECLARE + TYPE A IS ARRAY (I_5 RANGE -5 .. -6) OF I_5; + A1 : A; + BEGIN + IF A1'FIRST /= I_5(IDENT_INT(-5)) THEN + FAILED ("'FIRST OF NULL ARRAY INCORRECT"); + END IF; + END; + EXCEPTION + WHEN OTHERS => FAILED ("EXCEPTION RAISED 1"); + END; + + BEGIN + FOR I IN MID_WEEK RANGE SAT .. SUN LOOP + FAILED("LOOP WAS EXECUTED WITH NULL DISCRETE/INDEX RANGES"); + END LOOP; + FOR I IN MID_WEEK RANGE FRI .. WED LOOP + FAILED("LOOP WAS EXECUTED WITH NULL DISCRETE/INDEX RANGES"); + END LOOP; + FOR I IN MID_WEEK RANGE MON .. SUN LOOP + FAILED("LOOP WAS EXECUTED WITH NULL DISCRETE/INDEX RANGES"); + END LOOP; + FOR I IN I_5 RANGE 10 .. -10 LOOP + FAILED("LOOP WAS EXECUTED WITH NULL DISCRETE/INDEX RANGES"); + END LOOP; + FOR I IN I_5 RANGE 10 .. 9 LOOP + FAILED("LOOP WAS EXECUTED WITH NULL DISCRETE/INDEX RANGES"); + END LOOP; + FOR I IN I_5 RANGE -10 .. -11 LOOP + FAILED("LOOP WAS EXECUTED WITH NULL DISCRETE/INDEX RANGES"); + END LOOP; + FOR I IN I_5 RANGE -10 .. -20 LOOP + FAILED("LOOP WAS EXECUTED WITH NULL DISCRETE/INDEX RANGES"); + END LOOP; + FOR I IN I_5 RANGE 6 .. 5 LOOP + FAILED("LOOP WAS EXECUTED WITH NULL DISCRETE/INDEX RANGES"); + END LOOP; + EXCEPTION + WHEN OTHERS => FAILED ("EXCEPTION RAISED 3"); + END; + + BEGIN + DECLARE + TYPE P IS ACCESS I_5_ARRAY (-5 .. -6); + PA1 : P := NEW I_5_ARRAY (-5 .. -6); + BEGIN + IF PA1'LENGTH /= IDENT_INT(0) THEN + FAILED ("'LENGTH OF NULL ARRAY INCORRECT"); + END IF; + END; + EXCEPTION + WHEN OTHERS => + FAILED ("EXCEPTION RAISED 5"); + END; + + DECLARE + TYPE NARR IS ARRAY(INTEGER RANGE <>) OF INTEGER; + SUBTYPE SNARR IS INTEGER RANGE 1 .. 2; + W : NARR(SNARR) := (1,2); + BEGIN + IF W = (SNARR RANGE IDENT_INT(4) .. 2 => 5) THEN + FAILED("EVALUATION OF EXPRESSION IS INCORRECT"); + END IF; + EXCEPTION + WHEN OTHERS => FAILED ("EXCEPTION RAISED 7"); + END; + + DECLARE + W : WEEK_ARRAY (MID_WEEK); + BEGIN + W := (W'RANGE => WED); -- OK. + W (TUE .. MON) := W (MID_WEEK RANGE MON .. SUN); + EXCEPTION + WHEN OTHERS => FAILED ("EXCEPTION RAISED 8"); + END; + + BEGIN + DECLARE + W : WEEK_ARRAY (MID_WEEK RANGE MON .. SUN); + BEGIN + IF (W'FIRST /= MON) THEN + FAILED ("'FIRST OF NULL ARRAY INCORRECT"); + END IF; + END; + EXCEPTION + WHEN OTHERS => FAILED ("EXCEPTION RAISED 9"); + END; + + BEGIN + DECLARE + TYPE W IS NEW WEEK_ARRAY (MID_WEEK RANGE TUE .. MON); + W1 : W; + BEGIN + IF (W1'FIRST /= TUE) THEN + FAILED ("'FIRST OF NULL ARRAY INCORRECT"); + END IF; + END; + EXCEPTION + WHEN OTHERS => FAILED ("EXCEPTION RAISED 10"); + END; + + BEGIN + DECLARE + SUBTYPE W IS WEEK_ARRAY (MID_WEEK RANGE TUE .. MON); + W1 : W; + BEGIN + IF (W1'FIRST /= TUE) THEN + FAILED ("'FIRST OF NULL ARRAY INCORRECT"); + END IF; + END; + EXCEPTION + WHEN OTHERS => FAILED ("EXCEPTION RAISED 12"); + END; + + -- NULL MEMBERSHIP RANGES, EXCEPTION NOT RAISED. + + BEGIN + IF SUN IN SAT .. SUN + OR SAT IN FRI .. WED + OR WED IN THU .. TUE + OR THU IN MON .. SUN + OR FRI IN SAT .. FRI + OR WED IN FRI .. MON + THEN + FAILED ("INCORRECT 'IN' EVALUATION 1"); + END IF; + + IF INTEGER'(0) IN 10 .. -10 + OR INTEGER'(0) IN 10 .. 9 + OR INTEGER'(0) IN -10 .. -11 + OR INTEGER'(0) IN -10 .. -20 + OR INTEGER'(0) IN 6 .. 5 + OR INTEGER'(0) IN 5 .. 3 + OR INTEGER'(0) IN 7 .. 3 + THEN + FAILED ("INCORRECT 'IN' EVALUATION 2"); + END IF; + + IF WED NOT IN THU .. TUE + AND INTEGER'(0) NOT IN 4 .. -4 + THEN NULL; + ELSE FAILED ("INCORRECT 'NOT IN' EVALUATION"); + END IF; + EXCEPTION + WHEN OTHERS => FAILED ("EXCEPTION RAISED 52"); + END; + + + RESULT; +END C36104A; diff --git a/gcc-4.9/gcc/testsuite/ada/acats/tests/c3/c36104b.ada b/gcc-4.9/gcc/testsuite/ada/acats/tests/c3/c36104b.ada new file mode 100644 index 000000000..9c896b9df --- /dev/null +++ b/gcc-4.9/gcc/testsuite/ada/acats/tests/c3/c36104b.ada @@ -0,0 +1,421 @@ +-- C36104B.ADA + +-- Grant of Unlimited Rights +-- +-- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687, +-- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained +-- unlimited rights in the software and documentation contained herein. +-- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making +-- this public release, the Government intends to confer upon all +-- recipients unlimited rights equal to those held by the Government. +-- These rights include rights to use, duplicate, release or disclose the +-- released technical data and computer software in whole or in part, in +-- any manner and for any purpose whatsoever, and to have or permit others +-- to do so. +-- +-- DISCLAIMER +-- +-- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR +-- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED +-- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE +-- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE +-- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A +-- PARTICULAR PURPOSE OF SAID MATERIAL. +--* +-- CHECK THAT CONSTRAINT_ERROR IS RAISED OR NOT, AS APPROPRIATE, +-- DURING DISCRETE_RANGE ELABORATIONS/EVALUATIONS IN LOOPS, +-- ARRAY_TYPE_DEFINITIONS, ARRAY AGGREGATES, SLICES, +-- AND INDEX CONSTRAINTS IN OBJECT AND TYPE DECLARATIONS, WHERE +-- AN EXPLICIT (SUB)TYPE IS INCLUDED IN EACH DISCRETE_RANGE. +-- MEMBERSHIP OPERATORS ARE CHECKED HERE, ALSO, TO ENSURE THAT +-- EXCEPTIONS ARE NOT RAISED FOR NULL RANGES. +-- ONLY DYNAMIC CASES ARE CHECKED HERE. + +-- DAT 2/3/81 +-- JRK 2/25/81 +-- L.BROWN 7/15/86 1) ADDED ACCESS TYPES. +-- 2) DELETED "NULL INDEX RANGE, CONSTRAINT_ERROR +-- RAISED" SECTION. +-- 3) MADE USE OF DYNAMIC-RESULT FUNCTIONS. +-- 4) DELETED ALL REFERENCES TO CASE STATEMENT CHOICES +-- AND VARIANT PART CHOICES IN THE ABOVE COMMENT. +-- EDS 7/16/98 AVOID OPTIMIZATION + +WITH REPORT; +PROCEDURE C36104B IS + + USE REPORT; + + TYPE WEEK IS (SSUN, SMON, STUE, SWED, STHU, SFRI, SSAT); + SUN : WEEK := WEEK'VAL(IDENT_INT(0)); + MON : WEEK := WEEK'VAL(IDENT_INT(1)); + TUE : WEEK := WEEK'VAL(IDENT_INT(2)); + WED : WEEK := WEEK'VAL(IDENT_INT(3)); + THU : WEEK := WEEK'VAL(IDENT_INT(4)); + FRI : WEEK := WEEK'VAL(IDENT_INT(5)); + SAT : WEEK := WEEK'VAL(IDENT_INT(6)); + TYPE WEEK_ARRAY IS ARRAY (WEEK RANGE <>) OF WEEK; + SUBTYPE WORK_WEEK IS WEEK RANGE MON .. FRI; + SUBTYPE MID_WEEK IS WORK_WEEK RANGE TUE .. THU; + + TYPE INT_10 IS NEW INTEGER RANGE -10 .. 10; + TYPE I_10 IS NEW INT_10; + SUBTYPE I_5 IS I_10 RANGE I_10(IDENT_INT(-5)) .. + I_10(IDENT_INT(5)); + TYPE I_5_ARRAY IS ARRAY (I_5 RANGE <>) OF I_5; + + FUNCTION F(DAY : WEEK) RETURN WEEK IS + BEGIN + RETURN DAY; + END; + +BEGIN + TEST ("C36104B", "CONSTRAINT_ERROR IS RAISED OR NOT IN DYNAMIC " + & "DISCRETE_RANGES WITH EXPLICIT TYPE_MARKS"); + + -- NON-NULL RANGES, CONSTRAINT_ERROR RAISED. + + BEGIN + DECLARE + TYPE A IS ARRAY (I_5 RANGE 0 .. 6) OF I_5; + -- ABOVE DECLARATION RAISES CONSTRAINT_ERROR. + BEGIN + DECLARE + -- DEFINE AN OBJECT OF TYPE A AND USE IT TO AVOID + -- OPTIMIZATION OF SUBTYPE + A1 : A := (A'RANGE => I_5(IDENT_INT(1))); + BEGIN + FAILED ("CONSTRAINT_ERROR NOT RAISED 1 " & + I_5'IMAGE(A1(1)) ); --USE A1 + END; + EXCEPTION + --MAKE SURE THAT CONSTRAINT_ERROR FROM ABOVE STATEMENTS + --REPORT FAILED. + WHEN OTHERS => FAILED ("UNHANDLED EXCEPTION RAISED 1"); + END; + EXCEPTION + WHEN CONSTRAINT_ERROR => NULL; + WHEN OTHERS => + FAILED ("WRONG EXCEPTION RAISED 1"); + END; + + BEGIN + FOR I IN MID_WEEK RANGE MON .. MON LOOP + + IF EQUAL(2,2) THEN + SAT := SSAT; + END IF; + + END LOOP; + FAILED ("CONSTRAINT_ERROR NOT RAISED 3"); + EXCEPTION + WHEN CONSTRAINT_ERROR => NULL; + WHEN OTHERS => + FAILED ("WRONG EXCEPTION RAISED 3"); + END; + + BEGIN + DECLARE + TYPE P IS ACCESS I_5_ARRAY (0 .. 6); + -- ABOVE DECLARATION RAISES CONSTRAINT_ERROR. + BEGIN + DECLARE + TYPE PA IS NEW P; + -- DEFINE AN OBJECT OF TYPE PA AND USE IT TO AVOID + -- OPTIMIZATION OF TYPE + PA1 : PA :=NEW I_5_ARRAY'(0.. I_5(IDENT_INT(6)) => + I_5(IDENT_INT(1))); + BEGIN + FAILED ("CONSTRAINT_ERROR NOT RAISED 4 " & + I_5'IMAGE(PA1(1))); --USE PA1 + END; + EXCEPTION + WHEN OTHERS => FAILED ("UNHANDLED EXCEPTION RAISED 4"); + END; + EXCEPTION + WHEN CONSTRAINT_ERROR => NULL; + WHEN OTHERS => + FAILED ("WRONG EXCEPTION RAISED 4"); + END; + + DECLARE + W : WEEK_ARRAY (MID_WEEK); + BEGIN + W := (MID_WEEK RANGE MON .. WED => WED); + -- CONSTRAINT_ERROR RAISED. + BEGIN + FAILED ("CONSTRAINT_ERROR NOT RAISED 7 " & + MID_WEEK'IMAGE(W(WED))); --USE W + EXCEPTION + WHEN OTHERS => FAILED ("UNHANDLED EXCEPTION RAISED 7"); + END; + EXCEPTION + WHEN CONSTRAINT_ERROR => NULL; + WHEN OTHERS => + FAILED ("WRONG EXCEPTION RAISED 7"); + END; + + DECLARE + W : WEEK_ARRAY (WORK_WEEK); + BEGIN + W := (W'RANGE => WED); -- OK. + W (MON .. WED) := W (MID_WEEK RANGE MON .. WED); -- EXCEPTION. + BEGIN + FAILED ("CONSTRAINT_ERROR NOT RAISED 8 " & + MID_WEEK'IMAGE(W(WED))); --USE W + EXCEPTION + WHEN OTHERS => FAILED ("UNHANDLED EXCEPTION RAISED 8"); + END; + EXCEPTION + WHEN CONSTRAINT_ERROR => NULL; + WHEN OTHERS => + FAILED ("WRONG EXCEPTION RAISED 8"); + END; + + BEGIN + DECLARE + W : WEEK_ARRAY (MID_WEEK RANGE MON .. FRI); + -- ELABORATION OF ABOVE RAISES CONSTRAINT_ERROR. + BEGIN + W(WED) := THU; -- OK. + FAILED ("CONSTRAINT_ERROR NOT RAISED 9 " & + WEEK'IMAGE(W(WED))); -- USE W + END; + EXCEPTION + WHEN CONSTRAINT_ERROR => NULL; + WHEN OTHERS => + FAILED ("WRONG EXCEPTION RAISED 9"); + END; + + BEGIN + DECLARE + TYPE W IS NEW WEEK_ARRAY (MID_WEEK RANGE SUN .. WED); + -- RAISES CONSTRAINT_ERROR. + BEGIN + DECLARE + X : W; -- OK. + BEGIN + X(TUE) := THU; -- OK. + FAILED ("CONSTRAINT_ERROR NOT RAISED 10 " & + WEEK'IMAGE(X(TUE))); -- USE X + END; + EXCEPTION + WHEN OTHERS => + FAILED ("DID NOT RAISE CONSTRAINT_ERROR AT PROPER PLACE"); + END; + EXCEPTION + WHEN CONSTRAINT_ERROR => NULL; + WHEN OTHERS => + FAILED ("WRONG EXCEPTION RAISED 10"); + END; + + BEGIN + DECLARE + SUBTYPE W IS WEEK_ARRAY (MID_WEEK RANGE MON .. THU); + -- RAISES CONSTRAINT_ERROR. + BEGIN + DECLARE + T : W; -- OK. + BEGIN + T(TUE) := THU; -- OK. + FAILED ("CONSTRAINT_ERROR NOT RAISED 11 " & + WEEK'IMAGE(T(TUE))); + END; + EXCEPTION + WHEN OTHERS => + FAILED ("DID NOT RAISE CONSTRAINT_ERROR AT PROPER PLACE"); + END; + EXCEPTION + WHEN CONSTRAINT_ERROR => NULL; + WHEN OTHERS => + FAILED ("WRONG EXCEPTION RAISED 11"); + END; + + -- NULL DISCRETE/INDEX RANGES, EXCEPTION NOT RAISED. + + BEGIN + DECLARE + TYPE A IS ARRAY (I_5 RANGE I_5(IDENT_INT(-5)) .. -6) OF I_5; + A1 : A; + BEGIN + IF A1'FIRST /= I_5(IDENT_INT(-5)) THEN + FAILED ("'FIRST OF NULL ARRAY INCORRECT"); + END IF; + END; + EXCEPTION + WHEN OTHERS => FAILED ("EXCEPTION RAISED 1"); + END; + + BEGIN + FOR I IN MID_WEEK RANGE SAT .. SUN LOOP + + IF EQUAL(2,2) THEN + TUE := STUE; + END IF; + + END LOOP; + FOR I IN MID_WEEK RANGE FRI .. WED LOOP + + IF EQUAL(2,2) THEN + MON := SMON; + END IF; + + END LOOP; + FOR I IN MID_WEEK RANGE MON .. SUN LOOP + + IF EQUAL(3,3) THEN + WED := SWED; + END IF; + + END LOOP; + FOR I IN I_5 RANGE 10 .. -10 LOOP + + IF EQUAL(2,2) THEN + TUE := STUE; + END IF; + + END LOOP; + FOR I IN I_5 RANGE 10 .. 9 LOOP + + IF EQUAL(2,2) THEN + THU := STHU; + END IF; + + END LOOP; + FOR I IN I_5 RANGE -10 .. -11 LOOP + + IF EQUAL(2,2) THEN + SAT := SSAT; + END IF; + + END LOOP; + FOR I IN I_5 RANGE -10 .. -20 LOOP + + IF EQUAL(2,2) THEN + SUN := SSUN; + END IF; + + END LOOP; + FOR I IN I_5 RANGE 6 .. 5 LOOP + + IF EQUAL(2,2) THEN + MON := SMON; + END IF; + + END LOOP; + EXCEPTION + WHEN OTHERS => FAILED ("EXCEPTION RAISED 3"); + END; + + BEGIN + DECLARE + TYPE P IS ACCESS I_5_ARRAY (I_5(IDENT_INT(-5)) .. -6); + PA1 : P := NEW I_5_ARRAY (I_5(IDENT_INT(-5)) .. -6); + BEGIN + IF PA1'LENGTH /= IDENT_INT(0) THEN + FAILED ("'LENGTH OF NULL ARRAY INCORRECT"); + END IF; + END; + EXCEPTION + WHEN OTHERS => + FAILED ("EXCEPTION RAISED 5"); + END; + + DECLARE + TYPE NARR IS ARRAY(INTEGER RANGE <>) OF INTEGER; + SUBTYPE SNARR IS INTEGER RANGE 1 .. 2; + W : NARR(SNARR) := (1,2); + BEGIN + IF W = (SNARR RANGE IDENT_INT(4) .. 2 => 5) THEN + FAILED("EVALUATION OF EXPRESSION IS INCORRECT"); + END IF; + EXCEPTION + WHEN OTHERS => FAILED ("EXCEPTION RAISED 7"); + END; + + DECLARE + W : WEEK_ARRAY (MID_WEEK); + BEGIN + W := (W'RANGE => WED); -- OK. + W (TUE .. MON) := W (MID_WEEK RANGE MON .. SUN); + EXCEPTION + WHEN OTHERS => FAILED ("EXCEPTION RAISED 8"); + END; + + BEGIN + DECLARE + W : WEEK_ARRAY (MID_WEEK RANGE MON .. SUN); + BEGIN + + IF EQUAL(W'LENGTH,0) THEN + TUE := STUE; + END IF; + + END; + EXCEPTION + WHEN OTHERS => FAILED ("EXCEPTION RAISED 9"); + END; + + BEGIN + DECLARE + TYPE W IS NEW WEEK_ARRAY (MID_WEEK RANGE TUE .. MON); + BEGIN + + IF EQUAL(W'LENGTH,0) THEN + MON := SMON; + END IF; + + END; + EXCEPTION + WHEN OTHERS => FAILED ("EXCEPTION RAISED 10"); + END; + + BEGIN + DECLARE + SUBTYPE W IS WEEK_ARRAY (MID_WEEK RANGE TUE .. MON); + BEGIN + + IF EQUAL(W'LENGTH,0) THEN + WED := SWED; + END IF; + + END; + EXCEPTION + WHEN OTHERS => FAILED ("EXCEPTION RAISED 12"); + END; + + -- NULL MEMBERSHIP RANGES, EXCEPTION NOT RAISED. + + BEGIN + IF F(SUN) IN SAT .. SUN + OR SAT IN FRI .. WED + OR F(WED) IN THU .. TUE + OR THU IN MON .. SUN + OR F(FRI) IN SAT .. FRI + OR WED IN FRI .. MON + THEN + FAILED ("INCORRECT 'IN' EVALUATION 1"); + END IF; + + IF IDENT_INT(0) IN 10 .. IDENT_INT(-10) + OR 0 IN IDENT_INT(10) .. 9 + OR IDENT_INT(0) IN IDENT_INT(-10) .. -11 + OR 0 IN -10 .. IDENT_INT(-20) + OR IDENT_INT(0) IN 6 .. IDENT_INT(5) + OR 0 IN 5 .. IDENT_INT(3) + OR IDENT_INT(0) IN 7 .. IDENT_INT(3) + THEN + FAILED ("INCORRECT 'IN' EVALUATION 2"); + END IF; + + IF F(WED) NOT IN THU .. TUE + AND IDENT_INT(0) NOT IN IDENT_INT(4) .. -4 + THEN NULL; + ELSE FAILED ("INCORRECT 'NOT IN' EVALUATION"); + END IF; + EXCEPTION + WHEN OTHERS => FAILED ("EXCEPTION RAISED 52"); + END; + + RESULT; +END C36104B; diff --git a/gcc-4.9/gcc/testsuite/ada/acats/tests/c3/c36172a.ada b/gcc-4.9/gcc/testsuite/ada/acats/tests/c3/c36172a.ada new file mode 100644 index 000000000..9c9e6cf13 --- /dev/null +++ b/gcc-4.9/gcc/testsuite/ada/acats/tests/c3/c36172a.ada @@ -0,0 +1,250 @@ +-- C36172A.ADA + +-- Grant of Unlimited Rights +-- +-- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687, +-- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained +-- unlimited rights in the software and documentation contained herein. +-- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making +-- this public release, the Government intends to confer upon all +-- recipients unlimited rights equal to those held by the Government. +-- These rights include rights to use, duplicate, release or disclose the +-- released technical data and computer software in whole or in part, in +-- any manner and for any purpose whatsoever, and to have or permit others +-- to do so. +-- +-- DISCLAIMER +-- +-- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR +-- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED +-- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE +-- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE +-- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A +-- PARTICULAR PURPOSE OF SAID MATERIAL. +--* +-- CHECK THAT CONSTRAINT_ERROR IS RAISED APPROPRIATELY +-- ON DISCRETE_RANGES USED AS INDEX_CONSTRAINTS. + +-- DAT 2/9/81 +-- SPS 4/7/82 +-- JBG 6/5/85 + +WITH REPORT; +PROCEDURE C36172A IS + + USE REPORT; + + SUBTYPE INT_10 IS INTEGER RANGE 1 .. 10; + TYPE A IS ARRAY (INT_10 RANGE <> ) OF INTEGER; + + SUBTYPE INT_11 IS INTEGER RANGE 0 .. 11; + SUBTYPE NULL_6_4 IS INTEGER RANGE 6 .. 4; + SUBTYPE NULL_11_10 IS INTEGER RANGE 11 .. 10; + SUBTYPE INT_9_11 IS INTEGER RANGE 9 .. 11; + + TYPE A_9_11 IS ARRAY (9..11) OF BOOLEAN; + TYPE A_11_10 IS ARRAY (11 .. 10) OF INTEGER; + SUBTYPE A_1_10 IS A(INT_10); + +BEGIN + TEST ("C36172A", "CONSTRAINT_ERROR IS RAISED APPROPRIATELY" & + " FOR INDEX_RANGES"); + + BEGIN + DECLARE + V : A (9 .. 11); + BEGIN + IF EQUAL (V'FIRST, V'FIRST) THEN + FAILED ("OUT-OF-BOUNDS INDEX_RANGE 1"); + ELSE + FAILED ("IMPOSSIBLE"); + END IF; + END; + EXCEPTION + WHEN CONSTRAINT_ERROR => NULL; + WHEN OTHERS => FAILED ("WRONG EXCEPTION 1"); + END; + + BEGIN + DECLARE + V : A (11 .. 10); + BEGIN + IF EQUAL (V'FIRST, V'FIRST) THEN + NULL; + ELSE + FAILED ("IMPOSSIBLE"); + END IF; + END; + EXCEPTION + WHEN CONSTRAINT_ERROR => FAILED ("CONSTRAINT_ERROR " & + "RAISED INAPPROPRIATELY 2"); + WHEN OTHERS => FAILED ("EXCEPTION RAISED WHEN NONE " & + "SHOULD BE 2"); + END; + + BEGIN + DECLARE + V : A (6 .. 4); + BEGIN + IF EQUAL (V'FIRST, V'FIRST) THEN + NULL; + ELSE + FAILED ("IMPOSSIBLE"); + END IF; + END; + EXCEPTION + WHEN CONSTRAINT_ERROR => FAILED ("CONSTRAINT_ERROR " & + "RAISED INAPPROPRIATELY 3"); + WHEN OTHERS => FAILED ("EXCEPTION RAISED WHEN NONE " & + "SHOULD BE 3"); + END; + + BEGIN + DECLARE + V : A (INT_9_11); + BEGIN + IF EQUAL (V'FIRST, V'FIRST) THEN + FAILED ("OUT-OF-BOUNDS INDEX RANGE 4"); + ELSE + FAILED ("IMPOSSIBLE"); + END IF; + END; + EXCEPTION + WHEN CONSTRAINT_ERROR => NULL; + WHEN OTHERS => FAILED ("WRONG EXCEPTION 4"); + END; + + BEGIN + DECLARE + V : A (NULL_11_10); + BEGIN + IF EQUAL (V'FIRST, V'FIRST) THEN + NULL; + ELSE + FAILED ("IMPOSSIBLE"); + END IF; + END; + EXCEPTION + WHEN CONSTRAINT_ERROR => FAILED ("CONSTRAINT_ERROR " & + "RAISED INAPPROPRIATELY 5"); + WHEN OTHERS => FAILED ("EXCEPTION RAISED WHEN NONE " & + "SHOULD BE 5"); + END; + + BEGIN + DECLARE + V : A (NULL_6_4); + BEGIN + IF EQUAL (V'FIRST, V'FIRST) THEN + NULL; + ELSE + FAILED ("IMPOSSIBLE"); + END IF; + END; + EXCEPTION + WHEN CONSTRAINT_ERROR => FAILED ("CONSTRAINT_ERROR " & + "RAISED INAPPROPRIATELY 6"); + WHEN OTHERS => FAILED ("EXCEPTION RAISED WHEN NONE " & + "SHOULD BE 6"); + END; + + BEGIN + DECLARE + V : A (INT_9_11 RANGE 10 .. 11); + BEGIN + IF EQUAL (V'FIRST, V'FIRST) THEN + FAILED ("BAD NON-NULL INDEX RANGE 7"); + ELSE + FAILED ("IMPOSSIBLE"); + END IF; + END; + EXCEPTION + WHEN CONSTRAINT_ERROR => NULL; + WHEN OTHERS => FAILED ("WRONG EXCEPTION 7"); + END; + + BEGIN + DECLARE + V : A (NULL_11_10 RANGE 11 .. 10); + BEGIN + IF EQUAL (V'FIRST, V'FIRST) THEN + NULL; + ELSE + FAILED ("IMPOSSIBLE"); + END IF; + END; + EXCEPTION + WHEN CONSTRAINT_ERROR => FAILED ("CONSTRAINT_ERROR " & + "RAISED INAPPROPRIATELY 8"); + WHEN OTHERS => FAILED ("EXCEPTION RAISED WHEN NONE " & + "SHOULD BE 8"); + END; + + BEGIN + DECLARE + V : A (NULL_6_4 RANGE 6 .. 4); + BEGIN + IF EQUAL (V'FIRST, V'FIRST) THEN + NULL; + ELSE + FAILED ("IMPOSSIBLE"); + END IF; + END; + EXCEPTION + WHEN CONSTRAINT_ERROR => FAILED ("CONSTRAINT_ERROR " & + "RAISED INAPPROPRIATELY 9"); + WHEN OTHERS => FAILED ("EXCEPTION RAISED WHEN NONE " & + "SHOULD BE 9"); + END; + + BEGIN + DECLARE + V : A (A_9_11'RANGE); + BEGIN + IF EQUAL (V'FIRST, V'FIRST) THEN + FAILED ("BAD INDEX RANGE 10"); + ELSE + FAILED ("IMPOSSIBLE"); + END IF; + END; + EXCEPTION + WHEN CONSTRAINT_ERROR => NULL; + WHEN OTHERS => FAILED ("WRONG EXCEPTION 10"); + END; + + BEGIN + DECLARE + V : A (A_11_10'RANGE); + BEGIN + IF EQUAL (V'FIRST, V'FIRST) THEN + NULL; + ELSE + FAILED ("IMPOSSIBLE"); + END IF; + END; + EXCEPTION + WHEN CONSTRAINT_ERROR => FAILED ("CONSTRAINT_ERROR " & + "RAISED INAPPROPRIATELY 11"); + WHEN OTHERS => FAILED ("EXCEPTION RAISED WHEN NONE " & + "SHOULD BE 11"); + END; + + BEGIN + DECLARE + V : A (6 .. 4); + BEGIN + IF EQUAL (V'FIRST, V'FIRST) THEN + NULL; + ELSE + FAILED ("IMPOSSIBLE"); + END IF; + END; + EXCEPTION + WHEN CONSTRAINT_ERROR => FAILED ("CONSTRAINT_ERROR " & + "RAISED INAPPROPRIATELY 12"); + WHEN OTHERS => FAILED ("EXCEPTION RAISED WHEN NONE " & + "SHOULD BE 12"); + END; + + RESULT; +END C36172A; diff --git a/gcc-4.9/gcc/testsuite/ada/acats/tests/c3/c36172b.ada b/gcc-4.9/gcc/testsuite/ada/acats/tests/c3/c36172b.ada new file mode 100644 index 000000000..bf689b425 --- /dev/null +++ b/gcc-4.9/gcc/testsuite/ada/acats/tests/c3/c36172b.ada @@ -0,0 +1,161 @@ +-- C36172B.ADA + +-- Grant of Unlimited Rights +-- +-- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687, +-- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained +-- unlimited rights in the software and documentation contained herein. +-- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making +-- this public release, the Government intends to confer upon all +-- recipients unlimited rights equal to those held by the Government. +-- These rights include rights to use, duplicate, release or disclose the +-- released technical data and computer software in whole or in part, in +-- any manner and for any purpose whatsoever, and to have or permit others +-- to do so. +-- +-- DISCLAIMER +-- +-- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR +-- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED +-- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE +-- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE +-- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A +-- PARTICULAR PURPOSE OF SAID MATERIAL. +--* +-- CHECK THAT CONSTRAINT_ERROR IS RAISED FOR A MULTIDIMENSIONAL INDEX +-- CONSTRAINT IF ONE OF THE RANGES IS A NULL RANGE AND THE OTHER IS A +-- NON-NULL RANGE WITH A BOUND THAT LIES OUTSIDE THE INDEX SUBTYPE. + +-- CHECK THAT NO EXCEPTION IS RAISED IF ALL DISCRETE RANGES ARE NULL. + +-- JBG 6/5/85 +-- EDS 7/16/98 AVOID OPTIMIZATION + +WITH REPORT; USE REPORT; +PROCEDURE C36172B IS + SUBTYPE INT_10 IS INTEGER RANGE 1..10; + TYPE ARR2 IS ARRAY (INT_10 RANGE <>, INT_10 RANGE <>) OF INTEGER; +BEGIN + TEST ("C36172B", "CHECK THAT CONSTRAINT_ERROR IS RAISED FOR A " & + "NON-NULL DIMENSION OF A NULL MULTIDIMENSIONAL " & + "INDEX CONSTRAINT IF A BOUND LIES OUTSIDE THE " & + "INDEX SUBTYPE"); + + BEGIN + DECLARE + V : ARR2 (6..4, 9..11); + BEGIN + FAILED ("EXCEPTION NOT RAISED WHEN NON-NULL RANGE OF " & + "NULL INDEX CONSTRAINT HAS A BOUND OUTSIDE " & + "THE INDEX SUBTYPE (13) " & INTEGER'IMAGE(V'FIRST)); + END; + EXCEPTION + WHEN CONSTRAINT_ERROR => + NULL; + WHEN OTHERS => + FAILED ("UNEXPECTED EXCEPTION RAISED - 13"); + END; + + BEGIN + DECLARE + V : ARR2 (0..3, 8..7); + BEGIN + FAILED ("EXCEPTION NOT RAISED WHEN NON-NULL RANGE OF " & + "NULL INDEX CONSTRAINT HAS A BOUND OUTSIDE " & + "THE INDEX SUBTYPE (14) " & INTEGER'IMAGE(V'FIRST)); + END; + EXCEPTION + WHEN CONSTRAINT_ERROR => + NULL; + WHEN OTHERS => + FAILED ("UNEXPECTED EXCEPTION RAISED - 14"); + END; + + BEGIN + DECLARE + V : ARR2 (6..4, IDENT_INT(0)..2); + BEGIN + FAILED ("EXCEPTION NOT RAISED WHEN NON-NULL RANGE OF " & + "NULL INDEX CONSTRAINT HAS A BOUND OUTSIDE " & + "THE INDEX SUBTYPE (15) " & INTEGER'IMAGE(V'FIRST)); + END; + EXCEPTION + WHEN CONSTRAINT_ERROR => + NULL; + WHEN OTHERS => + FAILED ("UNEXPECTED EXCEPTION RAISED - 15"); + END; + + BEGIN + DECLARE + V : ARR2 (9..IDENT_INT(11), 6..4); + BEGIN + FAILED ("EXCEPTION NOT RAISED WHEN NON-NULL RANGE OF " & + "NULL INDEX CONSTRAINT HAS A BOUND OUTSIDE " & + "THE INDEX SUBTYPE (16) " & INTEGER'IMAGE(V'FIRST)); + END; + EXCEPTION + WHEN CONSTRAINT_ERROR => + NULL; + WHEN OTHERS => + FAILED ("UNEXPECTED EXCEPTION RAISED - 16"); + END; + + BEGIN + DECLARE + V : ARR2 (6..IDENT_INT(4), 9..IDENT_INT(11)); + BEGIN + FAILED ("EXCEPTION NOT RAISED WHEN NON-NULL RANGE OF " & + "NULL INDEX CONSTRAINT HAS A BOUND OUTSIDE " & + "THE INDEX SUBTYPE (17) " & INTEGER'IMAGE(V'FIRST)); + END; + EXCEPTION + WHEN CONSTRAINT_ERROR => + NULL; + WHEN OTHERS => + FAILED ("UNEXPECTED EXCEPTION RAISED - 17"); + END; + + BEGIN + DECLARE + V : ARR2 (IDENT_INT(-1)..2, IDENT_INT(6)..4); + BEGIN + FAILED ("EXCEPTION NOT RAISED WHEN NON-NULL RANGE OF " & + "NULL INDEX CONSTRAINT HAS A BOUND OUTSIDE " & + "THE INDEX SUBTYPE (18) " & INTEGER'IMAGE(V'FIRST)); + END; + EXCEPTION + WHEN CONSTRAINT_ERROR => + NULL; + WHEN OTHERS => + FAILED ("UNEXPECTED EXCEPTION RAISED - 18"); + END; + + BEGIN + DECLARE + V : ARR2 (6..-1, 11..9); + BEGIN + IF NOT EQUAL (V'FIRST, V'FIRST) THEN + FAILED ("IMPOSSIBLE"); + END IF; + END; + EXCEPTION + WHEN OTHERS => + FAILED ("EXCEPTION RAISED FOR NULL CONSTRAINT - 19"); + END; + + BEGIN + DECLARE + V : ARR2 (IDENT_INT(11)..9, 6..IDENT_INT(0)); + BEGIN + IF NOT EQUAL (V'FIRST, V'FIRST) THEN + FAILED ("IMPOSSIBLE"); + END IF; + END; + EXCEPTION + WHEN OTHERS => + FAILED ("EXCEPTION RAISED FOR NULL CONSTRAINT - 20"); + END; + + RESULT; +END C36172B; diff --git a/gcc-4.9/gcc/testsuite/ada/acats/tests/c3/c36172c.ada b/gcc-4.9/gcc/testsuite/ada/acats/tests/c3/c36172c.ada new file mode 100644 index 000000000..4d97fa13a --- /dev/null +++ b/gcc-4.9/gcc/testsuite/ada/acats/tests/c3/c36172c.ada @@ -0,0 +1,58 @@ +-- C36172C.ADA + +-- Grant of Unlimited Rights +-- +-- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687, +-- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained +-- unlimited rights in the software and documentation contained herein. +-- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making +-- this public release, the Government intends to confer upon all +-- recipients unlimited rights equal to those held by the Government. +-- These rights include rights to use, duplicate, release or disclose the +-- released technical data and computer software in whole or in part, in +-- any manner and for any purpose whatsoever, and to have or permit others +-- to do so. +-- +-- DISCLAIMER +-- +-- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR +-- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED +-- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF 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 NO EXCEPTION IS RAISED FOR A NULL ARRAY WHOSE DIFFERENCE +-- IN BOUNDS LIES OUTSIDE THE INDEX BASE TYPE. + +-- *** NOTE: This test has been modified since ACVC version 1.11 to -- 9X +-- *** remove incompatibilities associated with the transition -- 9X +-- *** to Ada 9X. -- 9X + +-- JBG 6/5/85 +-- JRL 03/30/93 REMOVED NUMERIC_ERROR FROM TEST. + +WITH REPORT; USE REPORT; +PROCEDURE C36172C IS +BEGIN + TEST ("C36172C", "CHECK THAT NO EXCEPTION IS RAISED FOR A NULL " & + "ARRAY WHOSE DIFFERENCE IN BOUNDS LIES OUTSIDE " & + "THE INDEX BASE TYPE"); + + BEGIN + DECLARE + V : STRING (INTEGER'LAST .. -2); + BEGIN + IF NOT EQUAL (V'FIRST, V'FIRST) THEN + FAILED ("IMPOSSIBLE"); + END IF; + END; + EXCEPTION + WHEN CONSTRAINT_ERROR => + FAILED ("CONSTRAINT_ERROR RAISED"); + WHEN OTHERS => + FAILED ("OTHER EXCEPTION RAISED"); + END; + + RESULT; +END C36172C; diff --git a/gcc-4.9/gcc/testsuite/ada/acats/tests/c3/c36174a.ada b/gcc-4.9/gcc/testsuite/ada/acats/tests/c3/c36174a.ada new file mode 100644 index 000000000..667512abc --- /dev/null +++ b/gcc-4.9/gcc/testsuite/ada/acats/tests/c3/c36174a.ada @@ -0,0 +1,118 @@ +-- C36174A.ADA + +-- Grant of Unlimited Rights +-- +-- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687, +-- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained +-- unlimited rights in the software and documentation contained herein. +-- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making +-- this public release, the Government intends to confer upon all +-- recipients unlimited rights equal to those held by the Government. +-- These rights include rights to use, duplicate, release or disclose the +-- released technical data and computer software in whole or in part, in +-- any manner and for any purpose whatsoever, and to have or permit others +-- to do so. +-- +-- DISCLAIMER +-- +-- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR +-- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED +-- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF 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 INDEX_CONSTRAINTS MAY BE OMITTED FOR CONSTANTS. + +-- DAT 2/9/81 +-- JBG 12/8/83 + + +WITH REPORT; +PROCEDURE C36174A IS + + USE REPORT; + + S0 : CONSTANT STRING := ""; + S1 : CONSTANT STRING := S0; + S2 : CONSTANT STRING := (1 .. 0 => 'Z'); + S3 : CONSTANT STRING := ('A', 'B', 'C'); + S4 : CONSTANT STRING := S3 & "ABC" & S3 & S2 & "Z"; + S9 : CONSTANT STRING := S0 & S1 & S2 & S3(3..1); + + TYPE A4 IS ARRAY(INTEGER RANGE <>, INTEGER RANGE <>, + INTEGER RANGE <>, INTEGER RANGE <>) OF STRING (1 .. 0); + C4 : CONSTANT A4 := + (-6 .. -4 => + (4 .. 5 => + (-4 .. -5 => + (1000 .. 2000 => + S9)))); + S10 : CONSTANT STRING := (10 .. 9 => 'Q'); + + TYPE I_12 IS NEW INTEGER RANGE 10 .. 12; + TYPE A_12 IS ARRAY (I_12 RANGE <>, I_12 RANGE <>) OF I_12; + A12 : CONSTANT A_12 := + (11 .. 12 => (10 .. 10 => 10)); + B12 : CONSTANT A_12 := + (11 => (10 | 12 => 10, 11 => 11), + 10 => (10 | 12 | 11 => 12)); + + N6 : CONSTANT INTEGER := IDENT_INT (6); + S6 : CONSTANT STRING := (N6 .. N6 + 6 => 'Z'); + S7 : CONSTANT STRING := S6 (N6 .. N6 + IDENT_INT (-1)); + +BEGIN + TEST ("C36174A", "INDEX_CONSTRAINTS MAY BE OMITTED FOR CONSTANTS"); + + IF S0'FIRST /= 1 OR S0'LAST /= 0 + OR S1'FIRST /= 1 OR S1'LAST /= 0 + OR S2'FIRST /= 1 OR S2'LAST /= 0 + OR S3'FIRST /= 1 OR S3'LAST /= 3 + THEN + FAILED ("INVALID STRING CONSTANT BOUNDS 1"); + END IF; + + IF S4'FIRST /= 1 OR S4'LAST /= 10 THEN + FAILED ("INVALID STRING CONSTANT BOUNDS 2"); + END IF; + + IF S9'FIRST /= 3 OR S9'LAST /= 1 THEN + FAILED ("INVALID STRING CONSTANT BOUNDS 3"); + END IF; + + IF C4'FIRST(1) /= -6 OR C4'LAST(1) /= -4 + OR C4'FIRST(2) /= 4 OR C4'LAST(2) /= 5 + OR C4'FIRST(3) /= -4 OR C4'LAST(3) /= -5 + OR C4'FIRST(4) /= 1000 OR C4'LAST(4) /= 2000 + THEN + FAILED ("INVALID ARRAY CONSTANT BOUNDS"); + END IF; + + IF S10'FIRST /= 10 OR S10'LAST /= 9 + THEN + FAILED ("INVALID STRING CONSTANT BOUNDS 10"); + END IF; + + IF A12'FIRST /= 11 OR A12'LAST /= 12 + OR A12'FIRST(2) /= 10 OR A12'LAST(2) /= 10 + THEN FAILED ("INVALID ARRAY CONSTANT BOUNDS 2"); + END IF; + + IF B12'FIRST /= 10 OR B12'LAST /= 11 + OR B12'FIRST(2) /= 10 OR B12'LAST(2) /= 12 + THEN + FAILED ("INVALID ARRAY CONSTANT BOUNDS 3"); + END IF; + + IF S6'FIRST /= 6 OR S6'LAST /= 12 OR S6'LENGTH /= 7 + THEN + FAILED ("INVALID STRING CONSTANT BOUNDS 12"); + END IF; + + IF S7'FIRST /= 6 OR S7'LAST /= 5 THEN + FAILED ("INVALID STRING CONSTANT BOUNDS 13"); + END IF; + + RESULT; +END C36174A; diff --git a/gcc-4.9/gcc/testsuite/ada/acats/tests/c3/c36180a.ada b/gcc-4.9/gcc/testsuite/ada/acats/tests/c3/c36180a.ada new file mode 100644 index 000000000..553809605 --- /dev/null +++ b/gcc-4.9/gcc/testsuite/ada/acats/tests/c3/c36180a.ada @@ -0,0 +1,136 @@ +-- C36180A.ADA + +-- Grant of Unlimited Rights +-- +-- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687, +-- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained +-- unlimited rights in the software and documentation contained herein. +-- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making +-- this public release, the Government intends to confer upon all +-- recipients unlimited rights equal to those held by the Government. +-- These rights include rights to use, duplicate, release or disclose the +-- released technical data and computer software in whole or in part, in +-- any manner and for any purpose whatsoever, and to have or permit others +-- to do so. +-- +-- DISCLAIMER +-- +-- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR +-- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED +-- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF 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 INDEX CONSTRAINT CAN HAVE THE FORM A'RANGE, +-- WHERE A IS A PREVIOUSLY DECLARED ARRAY OBJECT OR CONSTRAINED +-- ARRAY SUBTYPE. + +-- HISTORY: +-- BCB 01/21/88 CREATED ORIGINAL TEST. + +WITH REPORT; USE REPORT; + +PROCEDURE C36180A IS + + TYPE J IS ARRAY (INTEGER RANGE <>) OF INTEGER; + + TYPE K IS ARRAY (1..10) OF INTEGER; + + SUBTYPE A IS J (0 .. 50); + + SUBTYPE W IS J (A'RANGE); + + SUBTYPE X IS J (K'RANGE); + + TYPE Y IS ACCESS J; + + TYPE Z IS ACCESS J; + + TYPE F IS NEW J (A'RANGE); + + TYPE G IS NEW J (K'RANGE); + + B : ARRAY (A'RANGE) OF INTEGER; + + C : ARRAY (K'RANGE) OF INTEGER; + + D : ARRAY (1 .. 10) OF INTEGER; + + E : ARRAY (D'RANGE) OF INTEGER; + + H : J (A'RANGE); + + I : J (K'RANGE); + + L : J (D'RANGE); + + V1 : W; + + V2 : X; + + V3 : Y := NEW J (A'RANGE); + + V4 : Z := NEW J (K'RANGE); + + V5 : F; + + V6 : G; + +BEGIN + TEST ("C36180A", "CHECK THAT AN INDEX CONSTRAINT CAN HAVE THE " & + "FORM A'RANGE, WHERE A IS A PREVIOUSLY " & + "DECLARED ARRAY OBJECT OR CONSTRAINED ARRAY " & + "SUBTYPE"); + + IF B'FIRST /= IDENT_INT (0) OR B'LAST /= IDENT_INT (50) + THEN FAILED ("IMPROPER VALUE FOR B'FIRST OR B'LAST"); + END IF; + + IF C'FIRST /= IDENT_INT (1) OR C'LAST /= IDENT_INT (10) + THEN FAILED ("IMPROPER VALUE FOR C'FIRST OR C'LAST"); + END IF; + + IF E'FIRST /= IDENT_INT (1) OR E'LAST /= IDENT_INT (10) + THEN FAILED ("IMPROPER VALUE FOR E'FIRST OR E'LAST"); + END IF; + + IF H'FIRST /= IDENT_INT (0) OR H'LAST /= IDENT_INT (50) + THEN FAILED ("IMPROPER VALUE FOR H'FIRST OR H'LAST"); + END IF; + + IF I'FIRST /= IDENT_INT (1) OR I'LAST /= IDENT_INT (10) + THEN FAILED ("IMPROPER VALUE FOR I'FIRST OR I'LAST"); + END IF; + + IF L'FIRST /= IDENT_INT (1) OR L'LAST /= IDENT_INT (10) + THEN FAILED ("IMPROPER VALUE FOR L'FIRST OR L'LAST"); + END IF; + + IF V1'FIRST /= IDENT_INT (0) OR V1'LAST /= IDENT_INT (50) + THEN FAILED ("IMPROPER VALUE FOR V1'FIRST OR V1'LAST"); + END IF; + + IF V2'FIRST /= IDENT_INT (1) OR V2'LAST /= IDENT_INT (10) + THEN FAILED ("IMPROPER VALUE FOR V2'FIRST OR V2'LAST"); + END IF; + + IF V3.ALL'FIRST /= IDENT_INT (0) OR V3.ALL'LAST /= IDENT_INT (50) + THEN FAILED ("IMPROPER VALUE FOR V3'FIRST OR V3'LAST"); + END IF; + + IF V4.ALL'FIRST /= IDENT_INT (1) OR V4.ALL'LAST /= IDENT_INT (10) + THEN FAILED ("IMPROPER VALUE FOR V4'FIRST OR V4'LAST"); + END IF; + + IF V5'FIRST /= IDENT_INT (0) OR V5'LAST /= IDENT_INT (50) + THEN FAILED ("IMPROPER VALUE FOR V5'FIRST OR V5'LAST"); + END IF; + + IF V6'FIRST /= IDENT_INT (1) OR V6'LAST /= IDENT_INT (10) + THEN FAILED ("IMPROPER VALUE FOR V6'FIRST OR V6'LAST"); + END IF; + + RESULT; +END C36180A; diff --git a/gcc-4.9/gcc/testsuite/ada/acats/tests/c3/c36202c.ada b/gcc-4.9/gcc/testsuite/ada/acats/tests/c3/c36202c.ada new file mode 100644 index 000000000..03ca89e77 --- /dev/null +++ b/gcc-4.9/gcc/testsuite/ada/acats/tests/c3/c36202c.ada @@ -0,0 +1,87 @@ +-- C36202C.ADA + +-- Grant of Unlimited Rights +-- +-- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687, +-- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained +-- unlimited rights in the software and documentation contained herein. +-- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making +-- this public release, the Government intends to confer upon all +-- recipients unlimited rights equal to those held by the Government. +-- These rights include rights to use, duplicate, release or disclose the +-- released technical data and computer software in whole or in part, in +-- any manner and for any purpose whatsoever, and to have or permit others +-- to do so. +-- +-- DISCLAIMER +-- +-- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR +-- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED +-- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF 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 'LENGTH DOES NOT RAISE AN EXCEPTION +-- WHEN APPLIED TO A NULL ARRAY A, EVEN IF A'LAST - A'FIRST +-- WOULD RAISE CONSTRAINT_ERROR. + +-- *** NOTE: This test has been modified since ACVC version 1.11 to -- 9X +-- *** remove incompatibilities associated with the transition -- 9X +-- *** to Ada 9X. -- 9X + +-- L.BROWN 07/29/86 +-- JRL 03/30/93 REMOVED NUMERIC_ERROR FROM TEST. + +WITH REPORT; USE REPORT; +WITH SYSTEM; USE SYSTEM; + +PROCEDURE C36202C IS + + TYPE LRG_INT IS RANGE MIN_INT .. MAX_INT; + + BEGIN + TEST("C36202C", "NO EXCEPTION IS RAISED FOR 'LENGTH "& + "WHEN APPLIED TO A NULL ARRAY"); + + DECLARE + TYPE LRG_ARR IS ARRAY + (LRG_INT RANGE MAX_INT .. MIN_INT) + OF INTEGER; + LRG_OBJ : LRG_ARR; + + BEGIN + IF LRG_OBJ'LENGTH /= 0 THEN + FAILED("INCORRECT VALUE RETURNED BY 'LENGTH " & + "FOR ONE-DIM NULL ARRAY"); + END IF; + EXCEPTION + WHEN CONSTRAINT_ERROR => + FAILED("CONSTRAINT_ERROR WAS RAISED " & + "FOR ONE-DIM NULL ARRAY"); + WHEN OTHERS => + FAILED("EXCEPTION RAISED FOR ONE-DIM " & + "NULL ARRAY"); + END; + + DECLARE + TYPE LRG2_ARR IS ARRAY (LRG_INT RANGE 1 .. 3 , + LRG_INT RANGE MAX_INT .. MIN_INT) + OF INTEGER; + BEGIN + IF LRG2_ARR'LENGTH(2) /= 0 THEN + FAILED("INCORRECT VALUE RETURNED BY 'LENGTH " & + "FOR TWO-DIM NULL ARRAY"); + END IF; + EXCEPTION + WHEN CONSTRAINT_ERROR => + FAILED("CONSTRAINT_ERROR WAS RAISED " & + "FOR TWO-DIM NULL ARRAY"); + WHEN OTHERS => + FAILED("EXCEPTION RAISED FOR TWO-DIM " & + "NULL ARRAY"); + END; + + RESULT; + + END C36202C; diff --git a/gcc-4.9/gcc/testsuite/ada/acats/tests/c3/c36203a.ada b/gcc-4.9/gcc/testsuite/ada/acats/tests/c3/c36203a.ada new file mode 100644 index 000000000..f3f7e2bc7 --- /dev/null +++ b/gcc-4.9/gcc/testsuite/ada/acats/tests/c3/c36203a.ada @@ -0,0 +1,76 @@ +-- C36203A.ADA + +-- Grant of Unlimited Rights +-- +-- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687, +-- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained +-- unlimited rights in the software and documentation contained herein. +-- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making +-- this public release, the Government intends to confer upon all +-- recipients unlimited rights equal to those held by the Government. +-- These rights include rights to use, duplicate, release or disclose the +-- released technical data and computer software in whole or in part, in +-- any manner and for any purpose whatsoever, and to have or permit others +-- to do so. +-- +-- DISCLAIMER +-- +-- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR +-- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED +-- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF 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 'LENGTH YIELDS A RESULT OF TYPE UNIVERSAL INTEGER. + +-- L.BROWN 07/31/86 + +WITH REPORT; USE REPORT; +PROCEDURE C36203A IS + + TYPE NINT IS NEW INTEGER RANGE 1 .. 5; + + TYPE INT_ARR IS ARRAY(INTEGER RANGE 1 .. 3) OF INTEGER; + TYPE INT2_ARR IS ARRAY(INTEGER RANGE 1 .. 3, + INTEGER RANGE 1 .. 2) OF INTEGER; + + OBJA : INTEGER := 3; + OBJB : NINT := 3; + +BEGIN + TEST("C36203A", "'LENGTH YIELDS A RESULT OF TYPE " & + "UNIVERSAL INTEGER"); + IF (OBJA + INT_ARR'LENGTH) /= IDENT_INT(6) THEN + FAILED("INCORRECT VALUE RETURNED BY 'LENGTH " & + "FOR ONE-DIM ARRAY TYPE 1"); + END IF; + + IF (OBJB + INT_ARR'LENGTH) /= 6 THEN + FAILED("INCORRECT VALUE RETURNED BY 'LENGTH " & + "FOR ONE-DIM ARRAY TYPE 2"); + END IF; + + IF (OBJA + INT2_ARR'LENGTH(1)) /= IDENT_INT(6) THEN + FAILED("INCORRECT VALUE RETURNED BY 'LENGTH " & + "FOR FIRST DIMENSION OF TWO-DIM ARRAY TYPE 1"); + END IF; + + IF (OBJB + INT2_ARR'LENGTH(1)) /= 6 THEN + FAILED("INCORRECT VALUE RETURNED BY 'LENGTH " & + "FOR FIRST DIMENSION OF TWO-DIM ARRAY TYPE 2"); + END IF; + + IF (OBJA + INT2_ARR'LENGTH(2)) /= IDENT_INT(5) THEN + FAILED("INCORRECT VALUE RETURNED BY 'LENGTH " & + "FOR SECOND DIMENSION OF TWO-DIM ARRAY TYPE 1"); + END IF; + + IF (OBJB + INT2_ARR'LENGTH(2)) /= 5 THEN + FAILED("INCORRECT VALUE RETURNED BY 'LENGTH " & + "FOR SECOND DIMENSION OF TWO-DIM ARRAY TYPE 2"); + END IF; + + RESULT; + +END C36203A; diff --git a/gcc-4.9/gcc/testsuite/ada/acats/tests/c3/c36204a.ada b/gcc-4.9/gcc/testsuite/ada/acats/tests/c3/c36204a.ada new file mode 100644 index 000000000..4a4c37429 --- /dev/null +++ b/gcc-4.9/gcc/testsuite/ada/acats/tests/c3/c36204a.ada @@ -0,0 +1,142 @@ +-- C36204A.ADA + +-- Grant of Unlimited Rights +-- +-- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687, +-- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained +-- unlimited rights in the software and documentation contained herein. +-- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making +-- this public release, the Government intends to confer upon all +-- recipients unlimited rights equal to those held by the Government. +-- These rights include rights to use, duplicate, release or disclose the +-- released technical data and computer software in whole or in part, in +-- any manner and for any purpose whatsoever, and to have or permit others +-- to do so. +-- +-- DISCLAIMER +-- +-- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR +-- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED +-- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF 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 EACH ARRAY ATTRIBUTE YIELDS THE CORRECT VALUES. +-- BOTH ARRAY OBJECTS AND TYPES ARE CHECKED. + +-- DAT 2/12/81 +-- SPS 11/1/82 +-- WMC 03/16/92 CREATED TYPE RANGE CHECK FOR AE_TYPE. + +WITH REPORT; +PROCEDURE C36204A IS + + USE REPORT; + +BEGIN + TEST ("C36204A", "ARRAY ATTRIBUTES RETURN CORRECT VALUES"); + + DECLARE + A1 : ARRAY (BOOLEAN, + INTEGER RANGE IDENT_INT(1)..IDENT_INT(10)) + OF STRING(IDENT_INT(5)..IDENT_INT(7)); + TYPE NI IS RANGE -3 .. 3; + N : NI := NI(IDENT_INT(2)); + SUBTYPE SNI IS NI RANGE -N .. N; + TYPE AA IS ARRAY (NI, SNI, BOOLEAN) + OF NI; + A1_1_1 : BOOLEAN := A1'FIRST; + A1_1_2 : BOOLEAN := A1'LAST(1); + A1_2_1 : INTEGER RANGE A1'RANGE(2) := A1'FIRST(2); -- 1 + A1_2_2 : INTEGER RANGE A1'RANGE(2) := A1'LAST(2); -- 10 + SUBTYPE AE_TYPE IS INTEGER RANGE A1(TRUE,5)'RANGE; -- RANGE 5..7 + A2 : AA; + A4 : ARRAY (A1_1_1 .. A1_1_2, A1_2_1 .. A1_2_2) OF + STRING (IDENT_INT(1)..IDENT_INT(3)); + + I : INTEGER; + B : BOOLEAN; + BEGIN + IF A4'FIRST /= IDENT_BOOL(FALSE) + OR A4'LAST /= IDENT_BOOL(TRUE) + OR A4'FIRST(2) /= INTEGER'(1) + OR A4'LAST(2) /= INTEGER'(10) + THEN + FAILED ("INCORRECT 'FIRST OR 'LAST - 1"); + END IF; + + IF A4'LENGTH /= INTEGER'(2) + OR A4'LENGTH /= NI'(2) + OR A4'LENGTH(1) /= N + OR A4'LENGTH(2) /= A4'LAST(2) + THEN + FAILED ("INCORRECT 'LENGTH - 1"); + END IF; + + A4 := (BOOLEAN => (1 .. 10 => "XYZ")); + FOR L1 IN A1'RANGE(1) LOOP + FOR L2 IN A4'RANGE(2) LOOP + A1(L1,L2) := A4(L1,L2); + END LOOP; + END LOOP; + + IF AA'FIRST(1) /= NI'(-3) + OR AA'LAST(1) /= N + 1 + OR AA'FIRST(2) /= -N + OR AA'LAST(2) /= N + OR AA'FIRST(3) /= IDENT_BOOL(FALSE) + OR AA'LAST(3) /= IDENT_BOOL(TRUE) + THEN + FAILED ("INCORRECT 'FIRST OR 'LAST - 2"); + END IF; + + IF N NOT IN AA'RANGE(2) + OR IDENT_BOOL(FALSE) NOT IN AA'RANGE(3) + OR N + 1 NOT IN AA'RANGE + OR N + 1 IN AA'RANGE(2) + THEN + FAILED ("INCORRECT 'RANGE - 1"); + END IF; + + IF AA'LENGTH /= INTEGER'(7) + OR AA'LENGTH(2) - 3 /= N + OR AA'LENGTH(3) /= 2 + THEN + FAILED ("INCORRECT 'LENGTH - 2"); + END IF; + + IF A2'FIRST(1) /= NI'(-3) + OR A2'LAST(1) /= N + 1 + OR A2'FIRST(2) /= -N + OR A2'LAST(2) /= N + OR A2'FIRST(3) /= IDENT_BOOL(FALSE) + OR A2'LAST(3) /= IDENT_BOOL(TRUE) + THEN + FAILED ("INCORRECT 'FIRST OR 'LAST - 3"); + END IF; + + IF N NOT IN A2'RANGE(2) + OR IDENT_BOOL(FALSE) NOT IN A2'RANGE(3) + OR N + 1 NOT IN A2'RANGE + OR N + 1 IN A2'RANGE(2) + THEN + FAILED ("INCORRECT 'RANGE - 2"); + END IF; + + IF A2'LENGTH /= INTEGER'(7) + OR A2'LENGTH(2) - 3 /= INTEGER(N) + OR A2'LENGTH(3) /= 2 + THEN + FAILED ("INCORRECT 'LENGTH - 3"); + END IF; + + IF (AE_TYPE'FIRST /= 5) OR (AE_TYPE'LAST /= 7) THEN + FAILED ("INCORRECT TYPE RANGE DEFINED FOR AE_TYPE"); + END IF; + EXCEPTION + WHEN OTHERS => FAILED ("EXCEPTION RAISED ?"); + END; + + RESULT; +END C36204A; diff --git a/gcc-4.9/gcc/testsuite/ada/acats/tests/c3/c36204b.ada b/gcc-4.9/gcc/testsuite/ada/acats/tests/c3/c36204b.ada new file mode 100644 index 000000000..82f6b9369 --- /dev/null +++ b/gcc-4.9/gcc/testsuite/ada/acats/tests/c3/c36204b.ada @@ -0,0 +1,229 @@ +-- C36204B.ADA + +-- Grant of Unlimited Rights +-- +-- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687, +-- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained +-- unlimited rights in the software and documentation contained herein. +-- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making +-- this public release, the Government intends to confer upon all +-- recipients unlimited rights equal to those held by the Government. +-- These rights include rights to use, duplicate, release or disclose the +-- released technical data and computer software in whole or in part, in +-- any manner and for any purpose whatsoever, and to have or permit others +-- to do so. +-- +-- DISCLAIMER +-- +-- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR +-- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED +-- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF 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 EACH ARRAY ATTRIBUTE YIELDS THE CORRECT VALUES WITH +-- ACCESS VALUES AND FUNCTION CALLS AS THE PREFIXES. + +-- HISTORY: +-- L.BROWN 08/05/86 +-- DWC 07/24/87 DELETED BLANK AT END OF TEST DESCRIPTION. + +WITH REPORT; USE REPORT; + +PROCEDURE C36204B IS + + BEGIN + TEST("C36204B", "ARRAY ATTRIBUTES RETURN CORRECT VALUES " & + "FOR ACCESS VALUES AND FUNCTION CALLS AS " & + "PREFIXES"); + DECLARE + TYPE ARR1 IS ARRAY (INTEGER RANGE IDENT_INT(1) .. + IDENT_INT(10)) OF INTEGER ; + TYPE ARR2 IS ARRAY (BOOLEAN, + INTEGER RANGE IDENT_INT(1) .. + IDENT_INT(3)) OF INTEGER ; + + TYPE PTR1 IS ACCESS ARR1; + TYPE PTR2 IS ACCESS ARR2; + + PT1 : PTR1 := NEW ARR1'(ARR1'RANGE => 0); + PT2 : PTR2 := NEW ARR2'(ARR2'RANGE(1) => + (ARR2'RANGE(2) => 0)); + SUBTYPE ARR1_RANGE IS INTEGER RANGE PT1'RANGE; + BEGIN + IF PT1'FIRST /= IDENT_INT(1) THEN + FAILED("INCORRECT ATTRIBUTE VALUE FOR ONE-DIM " & + "ARRAY USING ACCESS TYPES AS PREFIXES 1"); + END IF; + + IF PT2'FIRST(2) /= IDENT_INT(1) THEN + FAILED("INCORRECT ATTRIBUTE VALUE FOR TWO-DIM " & + "ARRAY USING ACCESS TYPES AS PREFIXES 1"); + END IF; + + IF ARR1_RANGE'FIRST /= IDENT_INT(1) THEN + FAILED("INCORRECT ATTRIBUTE VALUE FOR ONE-DIM " & + "ARRAY USING ACCESS TYPES AS PREFIXES 2"); + END IF; + + IF PT1'LAST /= IDENT_INT(10) THEN + FAILED("INCORRECT ATTRIBUTE VALUE FOR ONE-DIM " & + "ARRAY USING ACCESS TYPES AS PREFIXES 3"); + END IF; + + IF PT2'LAST(2) /= IDENT_INT(3) THEN + FAILED("INCORRECT ATTRIBUTE VALUE FOR TWO-DIM " & + "ARRAY USING ACCESS TYPES AS PREFIXES 2"); + END IF; + + IF ARR1_RANGE'LAST /= IDENT_INT(10) THEN + FAILED("INCORRECT ATTRIBUTE VALUE FOR ONE-DIM " & + "ARRAY USING ACCESS TYPES AS PREFIXES 4"); + END IF; + + IF PT1'LENGTH /= IDENT_INT(10) THEN + FAILED("INCORRECT ATTRIBUTE VALUE FOR ONE-DIM " & + "ARRAY USING ACCESS TYPES AS PREFIXES 5"); + END IF; + + IF PT2'LENGTH(2) /= IDENT_INT(3) THEN + FAILED("INCORRECT ATTRIBUTE VALUE FOR TWO-DIM " & + "ARRAY USING ACCESS TYPES AS PREFIXES 3"); + END IF; + + END; + + DECLARE + + TYPE UNCON IS ARRAY (INTEGER RANGE <>) OF INTEGER ; + TYPE UNCON2 IS ARRAY (INTEGER RANGE <>, + INTEGER RANGE <>) OF INTEGER ; + + ARY1 : STRING(IDENT_INT(5) .. IDENT_INT(8)); + F : INTEGER := IDENT_INT(1); + L : INTEGER := IDENT_INT(3); + + FUNCTION FUN( LO,HI : INTEGER ) RETURN UNCON IS + ARR : UNCON(IDENT_INT(LO) .. IDENT_INT(HI)); + BEGIN + ARR := (ARR'RANGE => 0); + RETURN ARR; + END FUN; + + FUNCTION FUN2( LO,HI : INTEGER ) RETURN UNCON2 IS + AR2 : UNCON2(IDENT_INT(LO) .. IDENT_INT(HI), + IDENT_INT(LO) .. IDENT_INT(HI)); + BEGIN + AR2 := (AR2'RANGE(1) =>(AR2'RANGE(2) => 0)); + RETURN AR2; + END FUN2; + BEGIN + + ARY1 := (ARY1'RANGE => 'A'); + + IF FUN(F,L)'FIRST /= IDENT_INT(1) THEN + FAILED("INCORRECT ATTRIBUTE VALUE FOR ONE-DIM " & + "ARRAY USING FUNCTION RESULTS AS " & + "PREFIXES 1"); + END IF; + + IF FUN2(F,L)'FIRST(2) /= IDENT_INT(1) THEN + FAILED("INCORRECT ATTRIBUTE VALUE FOR TWO-DIM " & + "ARRAY USING FUNCTION RESULTS AS " & + "PREFIXES 1"); + END IF; + + IF "&"(ARY1,"XX")'FIRST /= IDENT_INT(5) THEN + FAILED("INCORRECT ATTRIBUTE VALUE FOR ONE-DIM " & + "ARRAY USING FUNCTION RESULTS AS " & + "PREFIXES 2"); + END IF; + + IF FUN(F,L)'LAST /= IDENT_INT(3) THEN + FAILED("INCORRECT ATTRIBUTE VALUE FOR ONE-DIM " & + "ARRAY USING FUNCTION RESULTS AS " & + "PREFIXES 3"); + END IF; + + IF FUN2(F,L)'LAST(2) /= IDENT_INT(3) THEN + FAILED("INCORRECT ATTRIBUTE VALUE FOR TWO-DIM " & + "ARRAY USING FUNCTION RESULTS AS " & + "PREFIXES 2"); + END IF; + + IF "&"(ARY1,"YY")'LAST /= IDENT_INT(10) THEN + FAILED("INCORRECT ATTRIBUTE VALUE FOR ONE-DIM " & + "ARRAY USING FUNCTION RESULTS AS " & + "PREFIXES 4"); + END IF; + + IF FUN(F,L)'LENGTH /= IDENT_INT(3) THEN + FAILED("INCORRECT ATTRIBUTE VALUE FOR ONE-DIM " & + "ARRAY USING FUNCTION RESULTS AS " & + "PREFIXES 5"); + END IF; + + IF FUN2(F,L)'LENGTH(2) /= IDENT_INT(3) THEN + FAILED("INCORRECT ATTRIBUTE VALUE FOR TWO-DIM " & + "ARRAY USING FUNCTION RESULTS AS " & + "PREFIXES 3"); + END IF; + + IF "&"(ARY1,"XX")'LENGTH /= IDENT_INT(6) THEN + FAILED("INCORRECT ATTRIBUTE VALUE FOR ONE-DIM " & + "ARRAY USING FUNCTION RESULTS AS " & + "PREFIXES 6"); + END IF; + + DECLARE + + SUBTYPE SMIN IS INTEGER RANGE FUN(F,L)'RANGE; + SUBTYPE SMIN2 IS INTEGER RANGE FUN2(F,L)'RANGE(2); + SUBTYPE SMIN3 IS INTEGER RANGE "&"(ARY1,"YY")'RANGE; + + BEGIN + IF SMIN'FIRST /= IDENT_INT(1) THEN + FAILED("INCORRECT ATTRIBUTE VALUE FOR " & + "ONE-DIM ARRAY USING FUNCTION " & + "RESULTS AS PREFIXES 7"); + END IF; + + IF SMIN2'FIRST /= IDENT_INT(1) THEN + FAILED("INCORRECT ATTRIBUTE VALUE FOR " & + "TWO-DIM ARRAY USING FUNCTION " & + "RESULTS AS PREFIXES 4"); + END IF; + + IF SMIN3'FIRST /= IDENT_INT(5) THEN + FAILED("INCORRECT ATTRIBUTE VALUE FOR " & + "ONE-DIM ARRAY USING FUNCTION " & + "RESULTS AS PREFIXES 8"); + END IF; + + IF SMIN'LAST /= IDENT_INT(3) THEN + FAILED("INCORRECT ATTRIBUTE VALUE FOR " & + "ONE-DIM ARRAY USING FUNCTION " & + "RESULTS AS PREFIXES 9"); + END IF; + + IF SMIN2'LAST /= IDENT_INT(3) THEN + FAILED("INCORRECT ATTRIBUTE VALUE FOR " & + "TWO-DIM ARRAY USING FUNCTION " & + "RESULTS AS PREFIXES 5"); + END IF; + + IF SMIN3'LAST /= IDENT_INT(10) THEN + FAILED("INCORRECT ATTRIBUTE VALUE FOR " & + "ONE-DIM ARRAY USING FUNCTION " & + "RESULTS AS PREFIXES 10"); + END IF; + + END; + + END; + + RESULT; + + END C36204B; diff --git a/gcc-4.9/gcc/testsuite/ada/acats/tests/c3/c36204c.ada b/gcc-4.9/gcc/testsuite/ada/acats/tests/c3/c36204c.ada new file mode 100644 index 000000000..171369528 --- /dev/null +++ b/gcc-4.9/gcc/testsuite/ada/acats/tests/c3/c36204c.ada @@ -0,0 +1,221 @@ +-- C36204C.ADA + +-- Grant of Unlimited Rights +-- +-- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687, +-- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained +-- unlimited rights in the software and documentation contained herein. +-- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making +-- this public release, the Government intends to confer upon all +-- recipients unlimited rights equal to those held by the Government. +-- These rights include rights to use, duplicate, release or disclose the +-- released technical data and computer software in whole or in part, in +-- any manner and for any purpose whatsoever, and to have or permit others +-- to do so. +-- +-- DISCLAIMER +-- +-- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR +-- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED +-- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF 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 'RANGE ATTRIBUTE CAN BE USED TO DECLARE OBJECTS +-- AND IN A SUBTYPE AND TYPE DECLARATION. + +-- HISTORY: +-- LB 08/13/86 CREATED ORIGINAL TEST. +-- BCB 08/18/87 CHANGED HEADER TO STANDARD HEADER FORMAT. +-- REARRANGED STATEMENTS SO TEST IS CALLED FIRST. +-- ELIMINATED DEAD VARIABLE OPTIMIZATION. CHECKED +-- RANGE VALUES FOR A SMALL INTEGER. + +WITH REPORT; USE REPORT; +PROCEDURE C36204C IS + +BEGIN + TEST("C36204C","USING 'RANGE TO DECLARE OBJECTS AND " & + "IN A SUBTYPE AND TYPE DECLARATION " & + "RETURNS THE CORRECT VALUES."); + + DECLARE + + ARR : ARRAY(IDENT_INT(4) .. IDENT_INT(10)) OF INTEGER; + OBJ1 : ARRAY(ARR'RANGE) OF BOOLEAN; + + SUBTYPE SMALL_INT IS INTEGER RANGE ARR'RANGE ; + SML : SMALL_INT; + + TYPE OTHER_ARR IS ARRAY(ARR'RANGE) OF CHARACTER; + OBJ2 : OTHER_ARR; + + TYPE ARR_TYPE IS ARRAY(INTEGER RANGE IDENT_INT(1) .. + IDENT_INT(10)) OF INTEGER; + TYPE ARR_PTR IS ACCESS ARR_TYPE; + PTR : ARR_PTR := NEW ARR_TYPE'(ARR_TYPE'RANGE => 0); + + FUNCTION F RETURN ARR_TYPE IS + AR : ARR_TYPE := (ARR_TYPE'RANGE => 0); + BEGIN + RETURN AR; + END F; + + BEGIN + BEGIN + IF OBJ1'FIRST /= IDENT_INT(4) THEN + FAILED("INCORRECT RANGE VALUE FOR AN OBJECT " & + "DECLARATION 1"); + END IF; + EXCEPTION + WHEN OTHERS => + FAILED("EXCEPTION RAISED WHEN CHECKING " & + "OBJECT DECLARATION 1"); + END; + + BEGIN + IF OBJ1'LAST /= IDENT_INT(10) THEN + FAILED("INCORRECT RANGE VALUE FOR AN OBJECT " & + "DECLARATION 2"); + END IF; + EXCEPTION + WHEN OTHERS => + FAILED("EXCEPTION RAISED WHEN CHECKING " & + "OBJECT DECLARATION 2"); + END; + + BEGIN + IF SMALL_INT'FIRST /= 4 THEN + FAILED("INCORRECT RANGE VALUE FOR A SMALL " & + "INTEGER DECLARATION 1"); + END IF; + EXCEPTION + WHEN OTHERS => + FAILED("EXCEPTION RAISED WHEN CHECKING SMALL" & + " INTEGER DECLARATION 1"); + END; + + BEGIN + IF SMALL_INT'LAST /= 10 THEN + FAILED("INCORRECT RANGE VALUE FOR A SMALL " & + "INTEGER DECLARATION 2"); + END IF; + EXCEPTION + WHEN OTHERS => + FAILED("EXCEPTION RAISED WHEN CHECKING SMALL" & + " INTEGER DECLARATION 2"); + END; + + BEGIN + SML := IDENT_INT(3) ; + IF SML = 3 THEN + COMMENT("VARIABLE SML OPTIMIZED VALUE 1"); + END IF; + FAILED("NO EXCEPTION RAISED FOR OUT-OF RANGE " & + "VALUE 1"); + EXCEPTION + WHEN CONSTRAINT_ERROR => + NULL; + WHEN OTHERS => + FAILED("WRONG EXCEPTION RAISED FOR OUT-OF " & + "RANGE VALUE 1"); + END; + + BEGIN + SML := IDENT_INT(11) ; + IF SML = 11 THEN + COMMENT("VARIABLE SML OPTIMIZED VALUE 2"); + END IF; + FAILED("NO EXCEPTION RAISED FOR OUT-OF RANGE " & + "VALUE 2"); + EXCEPTION + WHEN CONSTRAINT_ERROR => + NULL; + WHEN OTHERS => + FAILED("WRONG EXCEPTION RAISED FOR OUT-OF " & + "RANGE VALUE 2"); + END; + + BEGIN + IF OBJ2'FIRST /= IDENT_INT(4) THEN + FAILED("INCORRECT RANGE VALUE FOR A TYPE " & + "DECLARATION 1"); + END IF; + EXCEPTION + WHEN OTHERS => + FAILED("EXCEPTION RAISED WHEN CHECKING A " & + "TYPE DECLARATION 1"); + END; + + BEGIN + IF OBJ2'LAST /= IDENT_INT(10) THEN + FAILED("INCORRECT RANGE VALUE FOR A TYPE " & + "DECLARATION 2"); + END IF; + EXCEPTION + WHEN OTHERS => + FAILED("EXCEPTION RAISED WHEN CHECKING A " & + "TYPE DECLARATION 2"); + END; + + BEGIN + IF PTR'FIRST /= IDENT_INT(1) THEN + FAILED("INCORRECT RANGE VALUE FOR AN ACCESS " & + "TYPE DECLARATION 1"); + END IF; + EXCEPTION + WHEN OTHERS => + FAILED("EXCEPTION RAISED WHEN CHECKING AN " & + "ACCESS TYPE DECLARATION 1"); + END; + + BEGIN + IF PTR'LAST /= IDENT_INT(10) THEN + FAILED("INCORRECT RANGE VALUE FOR AN ACCESS " & + "TYPE DECLARATION 2"); + END IF; + EXCEPTION + WHEN OTHERS => + FAILED("EXCEPTION RAISED WHEN CHECKING AN " & + "ACCESS TYPE DECLARATION 2"); + END; + + DECLARE + OBJ_F1 : INTEGER RANGE F'RANGE ; + BEGIN + OBJ_F1 := IDENT_INT(0) ; + IF OBJ_F1 = 0 THEN + COMMENT("VARIABLE OBJ_F1 OPTIMIZED VALUE 1"); + END IF; + FAILED("NO EXCEPTION RAISED FOR OUT-OF RANGE " & + "VALUE 3"); + EXCEPTION + WHEN CONSTRAINT_ERROR => + NULL; + WHEN OTHERS => + FAILED("WRONG EXCEPTION RAISED FOR OUT-OF " & + "RANGE VALUE 3"); + END; + + DECLARE + OBJ_F2 : INTEGER RANGE F'RANGE ; + BEGIN + OBJ_F2 := IDENT_INT(11) ; + IF OBJ_F2 = 11 THEN + COMMENT("VARIABLE OBJ_F2 OPTIMIZED VALUE 1"); + END IF; + FAILED("NO EXCEPTION RAISED FOR OUT-OF RANGE " & + "VALUE 4"); + EXCEPTION + WHEN CONSTRAINT_ERROR => + NULL; + WHEN OTHERS => + FAILED("WRONG EXCEPTION RAISED FOR OUT-OF " & + "RANGE VALUE 4"); + END; + END; + RESULT; + +END C36204C; diff --git a/gcc-4.9/gcc/testsuite/ada/acats/tests/c3/c36204d.ada b/gcc-4.9/gcc/testsuite/ada/acats/tests/c3/c36204d.ada new file mode 100644 index 000000000..afdadbf53 --- /dev/null +++ b/gcc-4.9/gcc/testsuite/ada/acats/tests/c3/c36204d.ada @@ -0,0 +1,598 @@ +-- C36204D.ADA + +-- Grant of Unlimited Rights +-- +-- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687, +-- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained +-- unlimited rights in the software and documentation contained herein. +-- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making +-- this public release, the Government intends to confer upon all +-- recipients unlimited rights equal to those held by the Government. +-- These rights include rights to use, duplicate, release or disclose the +-- released technical data and computer software in whole or in part, in +-- any manner and for any purpose whatsoever, and to have or permit others +-- to do so. +-- +-- DISCLAIMER +-- +-- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR +-- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED +-- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF 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 EACH ARRAY ATTRIBUTE YIELDS THE CORRECT VALUES. +-- BOTH ARRAY OBJECTS AND TYPES ARE CHECKED. THIS TEST CHECKS +-- THE ABOVE FOR ARRAYS WITHIN GENERIC PROGRAM UNITS. + +-- HISTROY +-- EDWARD V. BERARD, 9 AUGUST 1990 + +WITH REPORT ; +WITH SYSTEM ; + +PROCEDURE C36204D IS + + SHORT_START : CONSTANT := -10 ; + SHORT_END : CONSTANT := 10 ; + TYPE SHORT_RANGE IS RANGE SHORT_START .. SHORT_END ; + SHORT_LENGTH : CONSTANT NATURAL := (SHORT_END - SHORT_START + 1) ; + + TYPE MONTH_TYPE IS (JAN, FEB, MAR, APR, MAY, JUN, JUL, AUG, + SEP, OCT, NOV, DEC) ; + SUBTYPE MID_YEAR IS MONTH_TYPE RANGE MAY .. AUG ; + TYPE DAY_TYPE IS RANGE 1 .. 31 ; + TYPE YEAR_TYPE IS RANGE 1904 .. 2050 ; + TYPE DATE IS RECORD + MONTH : MONTH_TYPE ; + DAY : DAY_TYPE ; + YEAR : YEAR_TYPE ; + END RECORD ; + + TODAY : DATE := (MONTH => AUG, + DAY => 10, + YEAR => 1990) ; + + FIRST_DATE : DATE := (DAY => 6, + MONTH => JUN, + YEAR => 1967) ; + + FUNCTION "=" (LEFT : IN SYSTEM.ADDRESS ; + RIGHT : IN SYSTEM.ADDRESS ) RETURN BOOLEAN + RENAMES SYSTEM."=" ; + + GENERIC + + TYPE FIRST_INDEX IS (<>) ; + FIRST_INDEX_LENGTH : IN NATURAL ; + FIRST_TEST_VALUE : IN FIRST_INDEX ; + TYPE SECOND_INDEX IS (<>) ; + SECOND_INDEX_LENGTH : IN NATURAL ; + SECOND_TEST_VALUE : IN SECOND_INDEX ; + TYPE THIRD_INDEX IS (<>) ; + THIRD_INDEX_LENGTH : IN NATURAL ; + THIRD_TEST_VALUE : IN THIRD_INDEX ; + TYPE FIRST_COMPONENT_TYPE IS PRIVATE ; + FIRST_DEFAULT_VALUE : IN FIRST_COMPONENT_TYPE ; + SECOND_DEFAULT_VALUE : IN FIRST_COMPONENT_TYPE ; + TYPE SECOND_COMPONENT_TYPE IS PRIVATE ; + THIRD_DEFAULT_VALUE : IN SECOND_COMPONENT_TYPE ; + FOURTH_DEFAULT_VALUE : IN SECOND_COMPONENT_TYPE ; + + PACKAGE ARRAY_ATTRIBUTE_TEST IS + + TYPE MATRIX IS ARRAY (FIRST_INDEX, SECOND_INDEX) + OF FIRST_COMPONENT_TYPE ; + + TYPE CUBE IS ARRAY (FIRST_INDEX, SECOND_INDEX, THIRD_INDEX) + OF SECOND_COMPONENT_TYPE ; + + END ARRAY_ATTRIBUTE_TEST ; + + PACKAGE BODY ARRAY_ATTRIBUTE_TEST IS + + FIRST_ARRAY : MATRIX := (FIRST_INDEX'FIRST .. FIRST_INDEX'LAST => + (SECOND_INDEX'FIRST .. SECOND_INDEX'LAST => + FIRST_DEFAULT_VALUE)) ; + + SECOND_ARRAY : CUBE := (FIRST_INDEX'FIRST .. FIRST_INDEX'LAST => + (SECOND_INDEX'FIRST .. SECOND_INDEX'LAST => + (THIRD_INDEX'FIRST .. THIRD_INDEX'LAST => + THIRD_DEFAULT_VALUE))) ; + + THIRD_ARRAY : CONSTANT MATRIX + := (FIRST_INDEX'FIRST .. FIRST_INDEX'LAST => + (SECOND_INDEX'FIRST .. SECOND_INDEX'LAST => + SECOND_DEFAULT_VALUE)) ; + + FOURTH_ARRAY : CONSTANT CUBE + := (FIRST_INDEX'FIRST .. FIRST_INDEX'LAST => + (SECOND_INDEX'FIRST .. SECOND_INDEX'LAST => + (THIRD_INDEX'FIRST .. THIRD_INDEX'LAST => + FOURTH_DEFAULT_VALUE))) ; + + FA1 : FIRST_INDEX := FIRST_ARRAY'FIRST (1) ; + FA2 : FIRST_INDEX := FIRST_ARRAY'LAST (1) ; + FA3 : SECOND_INDEX := FIRST_ARRAY'FIRST (2) ; + FA4 : SECOND_INDEX := FIRST_ARRAY'LAST (2) ; + + SA1 : FIRST_INDEX := SECOND_ARRAY'FIRST (1) ; + SA2 : FIRST_INDEX := SECOND_ARRAY'LAST (1) ; + SA3 : SECOND_INDEX := SECOND_ARRAY'FIRST (2) ; + SA4 : SECOND_INDEX := SECOND_ARRAY'LAST (2) ; + SA5 : THIRD_INDEX := SECOND_ARRAY'FIRST (3) ; + SA6 : THIRD_INDEX := SECOND_ARRAY'LAST (3) ; + + FAL1 : NATURAL := FIRST_ARRAY'LENGTH (1) ; + FAL2 : NATURAL := FIRST_ARRAY'LENGTH (2) ; + + SAL1 : NATURAL := SECOND_ARRAY'LENGTH (1) ; + SAL2 : NATURAL := SECOND_ARRAY'LENGTH (2) ; + SAL3 : NATURAL := SECOND_ARRAY'LENGTH (3) ; + + MATRIX_SIZE : NATURAL := MATRIX'SIZE ; + CUBE_SIZE : NATURAL := CUBE'SIZE ; + + FAA : SYSTEM.ADDRESS := FIRST_ARRAY'ADDRESS ; + SAA : SYSTEM.ADDRESS := SECOND_ARRAY'ADDRESS ; + TAA : SYSTEM.ADDRESS := THIRD_ARRAY'ADDRESS ; + FRAA : SYSTEM.ADDRESS := FOURTH_ARRAY'ADDRESS ; + + BEGIN -- ARRAY_ATTRIBUTE_TEST + + IF (FA1 /= FIRST_INDEX'FIRST) OR + (FA3 /= SECOND_INDEX'FIRST) OR + (SA1 /= FIRST_INDEX'FIRST) OR + (SA3 /= SECOND_INDEX'FIRST) OR + (SA5 /= THIRD_INDEX'FIRST) THEN + REPORT.FAILED ("INCORRECT VALUE RETURNED FOR 'FIRST - PACKAGE") ; + END IF ; + + IF (FA2 /= FIRST_INDEX'LAST) OR + (FA4 /= SECOND_INDEX'LAST) OR + (SA2 /= FIRST_INDEX'LAST) OR + (SA4 /= SECOND_INDEX'LAST) OR + (SA6 /= THIRD_INDEX'LAST) THEN + REPORT.FAILED ("INCORRECT VALUE RETURNED FOR 'LAST - PACKAGE") ; + END IF ; + + IF (FAL1 /= FIRST_INDEX_LENGTH) OR + (FAL2 /= SECOND_INDEX_LENGTH) OR + (SAL1 /= FIRST_INDEX_LENGTH) OR + (SAL2 /= SECOND_INDEX_LENGTH) OR + (SAL3 /= THIRD_INDEX_LENGTH) THEN + REPORT.FAILED ("INCORRECT VALUE RETURNED FOR 'LENGTH - PACKAGE") ; + END IF ; + + FOR OUTER_INDEX IN FIRST_ARRAY'RANGE (1) LOOP + FOR INNER_INDEX IN FIRST_ARRAY'RANGE (2) LOOP + FIRST_ARRAY (OUTER_INDEX, INNER_INDEX) := + SECOND_DEFAULT_VALUE ; + END LOOP ; + END LOOP ; + + IF FIRST_ARRAY /= THIRD_ARRAY THEN + REPORT.FAILED ("INCORRECT HANDLING OF 'RANGE ATTRIBUTE " & + "FOR 2-DIMENSIONAL ARRAY. - PACKAGE") ; + END IF ; + + FOR OUTER_INDEX IN SECOND_ARRAY'RANGE (1) LOOP + FOR MIDDLE_INDEX IN SECOND_ARRAY'RANGE (2) LOOP + FOR INNER_INDEX IN SECOND_ARRAY'RANGE (3) LOOP + SECOND_ARRAY (OUTER_INDEX, MIDDLE_INDEX, INNER_INDEX) + := FOURTH_DEFAULT_VALUE ; + END LOOP ; + END LOOP ; + END LOOP ; + + IF SECOND_ARRAY /= FOURTH_ARRAY THEN + REPORT.FAILED ("INCORRECT HANDLING OF 'RANGE ATTRIBUTE " & + "FOR 3-DIMENSIONAL ARRAY. - PACKAGE") ; + END IF ; + + IF (FIRST_TEST_VALUE NOT IN FIRST_ARRAY'RANGE (1)) OR + (FIRST_TEST_VALUE NOT IN SECOND_ARRAY'RANGE (1)) OR + (SECOND_TEST_VALUE NOT IN FIRST_ARRAY'RANGE (2)) OR + (SECOND_TEST_VALUE NOT IN SECOND_ARRAY'RANGE (2)) OR + (THIRD_TEST_VALUE NOT IN SECOND_ARRAY'RANGE (3)) THEN + REPORT.FAILED ("INCORRECT HANDLING OF 'RANGE ATTRIBUTE " & + "- PACKAGE") ; + END IF ; + + IF (MATRIX_SIZE = 0) OR (CUBE_SIZE = 0) THEN + REPORT.FAILED ("INCORRECT HANDLING OF THE 'SIZE ATTRIBUTE. " & + "- PACKAGE") ; + END IF ; + + IF (FAA = TAA) OR (SAA = FRAA) OR (FAA = SAA) OR (FAA = FRAA) + OR (SAA = TAA) OR (TAA = FRAA) THEN + REPORT.FAILED ("INCORRECT HANDLING OF THE 'ADDRESS ATTRIBUTE. " & + "- PACKAGE") ; + END IF ; + + END ARRAY_ATTRIBUTE_TEST ; + + GENERIC + + TYPE FIRST_INDEX IS (<>) ; + FIRST_INDEX_LENGTH : IN NATURAL ; + FIRST_TEST_VALUE : IN FIRST_INDEX ; + TYPE SECOND_INDEX IS (<>) ; + SECOND_INDEX_LENGTH : IN NATURAL ; + SECOND_TEST_VALUE : IN SECOND_INDEX ; + TYPE THIRD_INDEX IS (<>) ; + THIRD_INDEX_LENGTH : IN NATURAL ; + THIRD_TEST_VALUE : IN THIRD_INDEX ; + TYPE FIRST_COMPONENT_TYPE IS PRIVATE ; + FIRST_DEFAULT_VALUE : IN FIRST_COMPONENT_TYPE ; + SECOND_DEFAULT_VALUE : IN FIRST_COMPONENT_TYPE ; + TYPE SECOND_COMPONENT_TYPE IS PRIVATE ; + THIRD_DEFAULT_VALUE : IN SECOND_COMPONENT_TYPE ; + FOURTH_DEFAULT_VALUE : IN SECOND_COMPONENT_TYPE ; + + PROCEDURE PROC_ARRAY_ATT_TEST ; + + PROCEDURE PROC_ARRAY_ATT_TEST IS + + TYPE MATRIX IS ARRAY (FIRST_INDEX, SECOND_INDEX) + OF FIRST_COMPONENT_TYPE ; + + TYPE CUBE IS ARRAY (FIRST_INDEX, SECOND_INDEX, THIRD_INDEX) + OF SECOND_COMPONENT_TYPE ; + + FIRST_ARRAY : MATRIX := (FIRST_INDEX'FIRST .. FIRST_INDEX'LAST => + (SECOND_INDEX'FIRST .. SECOND_INDEX'LAST => + FIRST_DEFAULT_VALUE)) ; + + SECOND_ARRAY : CUBE := (FIRST_INDEX'FIRST .. FIRST_INDEX'LAST => + (SECOND_INDEX'FIRST .. SECOND_INDEX'LAST => + (THIRD_INDEX'FIRST .. THIRD_INDEX'LAST => + THIRD_DEFAULT_VALUE))) ; + + THIRD_ARRAY : CONSTANT MATRIX + := (FIRST_INDEX'FIRST .. FIRST_INDEX'LAST => + (SECOND_INDEX'FIRST .. SECOND_INDEX'LAST => + SECOND_DEFAULT_VALUE)) ; + + FOURTH_ARRAY : CONSTANT CUBE + := (FIRST_INDEX'FIRST .. FIRST_INDEX'LAST => + (SECOND_INDEX'FIRST .. SECOND_INDEX'LAST => + (THIRD_INDEX'FIRST .. THIRD_INDEX'LAST => + FOURTH_DEFAULT_VALUE))) ; + + FA1 : FIRST_INDEX := FIRST_ARRAY'FIRST (1) ; + FA2 : FIRST_INDEX := FIRST_ARRAY'LAST (1) ; + FA3 : SECOND_INDEX := FIRST_ARRAY'FIRST (2) ; + FA4 : SECOND_INDEX := FIRST_ARRAY'LAST (2) ; + + SA1 : FIRST_INDEX := SECOND_ARRAY'FIRST (1) ; + SA2 : FIRST_INDEX := SECOND_ARRAY'LAST (1) ; + SA3 : SECOND_INDEX := SECOND_ARRAY'FIRST (2) ; + SA4 : SECOND_INDEX := SECOND_ARRAY'LAST (2) ; + SA5 : THIRD_INDEX := SECOND_ARRAY'FIRST (3) ; + SA6 : THIRD_INDEX := SECOND_ARRAY'LAST (3) ; + + FAL1 : NATURAL := FIRST_ARRAY'LENGTH (1) ; + FAL2 : NATURAL := FIRST_ARRAY'LENGTH (2) ; + + SAL1 : NATURAL := SECOND_ARRAY'LENGTH (1) ; + SAL2 : NATURAL := SECOND_ARRAY'LENGTH (2) ; + SAL3 : NATURAL := SECOND_ARRAY'LENGTH (3) ; + + MATRIX_SIZE : NATURAL := MATRIX'SIZE ; + CUBE_SIZE : NATURAL := CUBE'SIZE ; + + FAA : SYSTEM.ADDRESS := FIRST_ARRAY'ADDRESS ; + SAA : SYSTEM.ADDRESS := SECOND_ARRAY'ADDRESS ; + TAA : SYSTEM.ADDRESS := THIRD_ARRAY'ADDRESS ; + FRAA : SYSTEM.ADDRESS := FOURTH_ARRAY'ADDRESS ; + + BEGIN -- PROC_ARRAY_ATT_TEST + + IF (FA1 /= FIRST_INDEX'FIRST) OR + (FA3 /= SECOND_INDEX'FIRST) OR + (SA1 /= FIRST_INDEX'FIRST) OR + (SA3 /= SECOND_INDEX'FIRST) OR + (SA5 /= THIRD_INDEX'FIRST) THEN + REPORT.FAILED ("INCORRECT VALUE RETURNED FOR 'FIRST " & + "- PROCEDURE") ; + END IF ; + + IF (FA2 /= FIRST_INDEX'LAST) OR + (FA4 /= SECOND_INDEX'LAST) OR + (SA2 /= FIRST_INDEX'LAST) OR + (SA4 /= SECOND_INDEX'LAST) OR + (SA6 /= THIRD_INDEX'LAST) THEN + REPORT.FAILED ("INCORRECT VALUE RETURNED FOR 'LAST " & + "- PROCEDURE") ; + END IF ; + + IF (FAL1 /= FIRST_INDEX_LENGTH) OR + (FAL2 /= SECOND_INDEX_LENGTH) OR + (SAL1 /= FIRST_INDEX_LENGTH) OR + (SAL2 /= SECOND_INDEX_LENGTH) OR + (SAL3 /= THIRD_INDEX_LENGTH) THEN + REPORT.FAILED ("INCORRECT VALUE RETURNED FOR 'LENGTH " & + "- PROCEDURE") ; + END IF ; + + FOR OUTER_INDEX IN FIRST_ARRAY'RANGE (1) LOOP + FOR INNER_INDEX IN FIRST_ARRAY'RANGE (2) LOOP + FIRST_ARRAY (OUTER_INDEX, INNER_INDEX) := + SECOND_DEFAULT_VALUE ; + END LOOP ; + END LOOP ; + + IF FIRST_ARRAY /= THIRD_ARRAY THEN + REPORT.FAILED ("INCORRECT HANDLING OF 'RANGE ATTRIBUTE " & + "FOR 2-DIMENSIONAL ARRAY. - PROCEDURE") ; + END IF ; + + FOR OUTER_INDEX IN SECOND_ARRAY'RANGE (1) LOOP + FOR MIDDLE_INDEX IN SECOND_ARRAY'RANGE (2) LOOP + FOR INNER_INDEX IN SECOND_ARRAY'RANGE (3) LOOP + SECOND_ARRAY (OUTER_INDEX, MIDDLE_INDEX, INNER_INDEX) + := FOURTH_DEFAULT_VALUE ; + END LOOP ; + END LOOP ; + END LOOP ; + + IF SECOND_ARRAY /= FOURTH_ARRAY THEN + REPORT.FAILED ("INCORRECT HANDLING OF 'RANGE ATTRIBUTE " & + "FOR 3-DIMENSIONAL ARRAY. - PROCEDURE") ; + END IF ; + + IF (FIRST_TEST_VALUE NOT IN FIRST_ARRAY'RANGE (1)) OR + (FIRST_TEST_VALUE NOT IN SECOND_ARRAY'RANGE (1)) OR + (SECOND_TEST_VALUE NOT IN FIRST_ARRAY'RANGE (2)) OR + (SECOND_TEST_VALUE NOT IN SECOND_ARRAY'RANGE (2)) OR + (THIRD_TEST_VALUE NOT IN SECOND_ARRAY'RANGE (3)) THEN + REPORT.FAILED ("INCORRECT HANDLING OF 'RANGE ATTRIBUTE " & + "- PROCEDURE") ; + END IF ; + + IF (MATRIX_SIZE = 0) OR (CUBE_SIZE = 0) THEN + REPORT.FAILED ("INCORRECT HANDLING OF THE 'SIZE ATTRIBUTE. " & + "- PROCEDURE") ; + END IF ; + + IF (FAA = TAA) OR (SAA = FRAA) OR (FAA = SAA) OR (FAA = FRAA) + OR (SAA = TAA) OR (TAA = FRAA) THEN + REPORT.FAILED ("INCORRECT HANDLING OF THE 'ADDRESS ATTRIBUTE. " & + "- PROCEDURE") ; + END IF ; + + END PROC_ARRAY_ATT_TEST ; + + GENERIC + + TYPE FIRST_INDEX IS (<>) ; + FIRST_INDEX_LENGTH : IN NATURAL ; + FIRST_TEST_VALUE : IN FIRST_INDEX ; + TYPE SECOND_INDEX IS (<>) ; + SECOND_INDEX_LENGTH : IN NATURAL ; + SECOND_TEST_VALUE : IN SECOND_INDEX ; + TYPE THIRD_INDEX IS (<>) ; + THIRD_INDEX_LENGTH : IN NATURAL ; + THIRD_TEST_VALUE : IN THIRD_INDEX ; + TYPE FIRST_COMPONENT_TYPE IS PRIVATE ; + FIRST_DEFAULT_VALUE : IN FIRST_COMPONENT_TYPE ; + SECOND_DEFAULT_VALUE : IN FIRST_COMPONENT_TYPE ; + TYPE SECOND_COMPONENT_TYPE IS PRIVATE ; + THIRD_DEFAULT_VALUE : IN SECOND_COMPONENT_TYPE ; + FOURTH_DEFAULT_VALUE : IN SECOND_COMPONENT_TYPE ; + + FUNCTION FUNC_ARRAY_ATT_TEST RETURN BOOLEAN ; + + FUNCTION FUNC_ARRAY_ATT_TEST RETURN BOOLEAN IS + + TYPE MATRIX IS ARRAY (FIRST_INDEX, SECOND_INDEX) + OF FIRST_COMPONENT_TYPE ; + + TYPE CUBE IS ARRAY (FIRST_INDEX, SECOND_INDEX, THIRD_INDEX) + OF SECOND_COMPONENT_TYPE ; + + FIRST_ARRAY : MATRIX := (FIRST_INDEX'FIRST .. FIRST_INDEX'LAST => + (SECOND_INDEX'FIRST .. SECOND_INDEX'LAST => + FIRST_DEFAULT_VALUE)) ; + + SECOND_ARRAY : CUBE := (FIRST_INDEX'FIRST .. FIRST_INDEX'LAST => + (SECOND_INDEX'FIRST .. SECOND_INDEX'LAST => + (THIRD_INDEX'FIRST .. THIRD_INDEX'LAST => + THIRD_DEFAULT_VALUE))) ; + + THIRD_ARRAY : CONSTANT MATRIX + := (FIRST_INDEX'FIRST .. FIRST_INDEX'LAST => + (SECOND_INDEX'FIRST .. SECOND_INDEX'LAST => + SECOND_DEFAULT_VALUE)) ; + + FOURTH_ARRAY : CONSTANT CUBE + := (FIRST_INDEX'FIRST .. FIRST_INDEX'LAST => + (SECOND_INDEX'FIRST .. SECOND_INDEX'LAST => + (THIRD_INDEX'FIRST .. THIRD_INDEX'LAST => + FOURTH_DEFAULT_VALUE))) ; + + FA1 : FIRST_INDEX := FIRST_ARRAY'FIRST (1) ; + FA2 : FIRST_INDEX := FIRST_ARRAY'LAST (1) ; + FA3 : SECOND_INDEX := FIRST_ARRAY'FIRST (2) ; + FA4 : SECOND_INDEX := FIRST_ARRAY'LAST (2) ; + + SA1 : FIRST_INDEX := SECOND_ARRAY'FIRST (1) ; + SA2 : FIRST_INDEX := SECOND_ARRAY'LAST (1) ; + SA3 : SECOND_INDEX := SECOND_ARRAY'FIRST (2) ; + SA4 : SECOND_INDEX := SECOND_ARRAY'LAST (2) ; + SA5 : THIRD_INDEX := SECOND_ARRAY'FIRST (3) ; + SA6 : THIRD_INDEX := SECOND_ARRAY'LAST (3) ; + + FAL1 : NATURAL := FIRST_ARRAY'LENGTH (1) ; + FAL2 : NATURAL := FIRST_ARRAY'LENGTH (2) ; + + SAL1 : NATURAL := SECOND_ARRAY'LENGTH (1) ; + SAL2 : NATURAL := SECOND_ARRAY'LENGTH (2) ; + SAL3 : NATURAL := SECOND_ARRAY'LENGTH (3) ; + + MATRIX_SIZE : NATURAL := MATRIX'SIZE ; + CUBE_SIZE : NATURAL := CUBE'SIZE ; + + FAA : SYSTEM.ADDRESS := FIRST_ARRAY'ADDRESS ; + SAA : SYSTEM.ADDRESS := SECOND_ARRAY'ADDRESS ; + TAA : SYSTEM.ADDRESS := THIRD_ARRAY'ADDRESS ; + FRAA : SYSTEM.ADDRESS := FOURTH_ARRAY'ADDRESS ; + + BEGIN -- FUNC_ARRAY_ATT_TEST + + IF (FA1 /= FIRST_INDEX'FIRST) OR + (FA3 /= SECOND_INDEX'FIRST) OR + (SA1 /= FIRST_INDEX'FIRST) OR + (SA3 /= SECOND_INDEX'FIRST) OR + (SA5 /= THIRD_INDEX'FIRST) THEN + REPORT.FAILED ("INCORRECT VALUE RETURNED FOR 'FIRST " & + "- FUNCTION") ; + END IF ; + + IF (FA2 /= FIRST_INDEX'LAST) OR + (FA4 /= SECOND_INDEX'LAST) OR + (SA2 /= FIRST_INDEX'LAST) OR + (SA4 /= SECOND_INDEX'LAST) OR + (SA6 /= THIRD_INDEX'LAST) THEN + REPORT.FAILED ("INCORRECT VALUE RETURNED FOR 'LAST " & + "- FUNCTION") ; + END IF ; + + IF (FAL1 /= FIRST_INDEX_LENGTH) OR + (FAL2 /= SECOND_INDEX_LENGTH) OR + (SAL1 /= FIRST_INDEX_LENGTH) OR + (SAL2 /= SECOND_INDEX_LENGTH) OR + (SAL3 /= THIRD_INDEX_LENGTH) THEN + REPORT.FAILED ("INCORRECT VALUE RETURNED FOR 'LENGTH " & + "- FUNCTION") ; + END IF ; + + FOR OUTER_INDEX IN FIRST_ARRAY'RANGE (1) LOOP + FOR INNER_INDEX IN FIRST_ARRAY'RANGE (2) LOOP + FIRST_ARRAY (OUTER_INDEX, INNER_INDEX) := + SECOND_DEFAULT_VALUE ; + END LOOP ; + END LOOP ; + + IF FIRST_ARRAY /= THIRD_ARRAY THEN + REPORT.FAILED ("INCORRECT HANDLING OF 'RANGE ATTRIBUTE " & + "FOR 2-DIMENSIONAL ARRAY. - FUNCTION") ; + END IF ; + + FOR OUTER_INDEX IN SECOND_ARRAY'RANGE (1) LOOP + FOR MIDDLE_INDEX IN SECOND_ARRAY'RANGE (2) LOOP + FOR INNER_INDEX IN SECOND_ARRAY'RANGE (3) LOOP + SECOND_ARRAY (OUTER_INDEX, MIDDLE_INDEX, INNER_INDEX) + := FOURTH_DEFAULT_VALUE ; + END LOOP ; + END LOOP ; + END LOOP ; + + IF SECOND_ARRAY /= FOURTH_ARRAY THEN + REPORT.FAILED ("INCORRECT HANDLING OF 'RANGE ATTRIBUTE " & + "FOR 3-DIMENSIONAL ARRAY. - FUNCTION") ; + END IF ; + + IF (FIRST_TEST_VALUE NOT IN FIRST_ARRAY'RANGE (1)) OR + (FIRST_TEST_VALUE NOT IN SECOND_ARRAY'RANGE (1)) OR + (SECOND_TEST_VALUE NOT IN FIRST_ARRAY'RANGE (2)) OR + (SECOND_TEST_VALUE NOT IN SECOND_ARRAY'RANGE (2)) OR + (THIRD_TEST_VALUE NOT IN SECOND_ARRAY'RANGE (3)) THEN + REPORT.FAILED ("INCORRECT HANDLING OF 'RANGE ATTRIBUTE " & + "- FUNCTION") ; + END IF ; + + IF (MATRIX_SIZE = 0) OR (CUBE_SIZE = 0) THEN + REPORT.FAILED ("INCORRECT HANDLING OF THE 'SIZE ATTRIBUTE. " & + "- FUNCTION") ; + END IF ; + + IF (FAA = TAA) OR (SAA = FRAA) OR (FAA = SAA) OR (FAA = FRAA) + OR (SAA = TAA) OR (TAA = FRAA) THEN + REPORT.FAILED ("INCORRECT HANDLING OF THE 'ADDRESS ATTRIBUTE. " & + "- FUNCTION") ; + END IF ; + + RETURN TRUE ; + + END FUNC_ARRAY_ATT_TEST ; + + +BEGIN -- C36204D + + REPORT.TEST ("C36204D", "ARRAY ATTRIBUTES RETURN CORRECT " & + "VALUES WITHIN GENERIC PROGRAM UNITS.") ; + + LOCAL_BLOCK: + + DECLARE + + DUMMY : BOOLEAN := FALSE ; + + PACKAGE NEW_ARRAY_ATTRIBUTE_TEST IS NEW ARRAY_ATTRIBUTE_TEST ( + FIRST_INDEX => SHORT_RANGE, + FIRST_INDEX_LENGTH => SHORT_LENGTH, + FIRST_TEST_VALUE => -7, + SECOND_INDEX => MONTH_TYPE, + SECOND_INDEX_LENGTH => 12, + SECOND_TEST_VALUE => AUG, + THIRD_INDEX => BOOLEAN, + THIRD_INDEX_LENGTH => 2, + THIRD_TEST_VALUE => FALSE, + FIRST_COMPONENT_TYPE => MONTH_TYPE, + FIRST_DEFAULT_VALUE => JAN, + SECOND_DEFAULT_VALUE => DEC, + SECOND_COMPONENT_TYPE => DATE, + THIRD_DEFAULT_VALUE => TODAY, + FOURTH_DEFAULT_VALUE => FIRST_DATE) ; + + PROCEDURE NEW_PROC_ARRAY_ATT_TEST IS NEW PROC_ARRAY_ATT_TEST ( + FIRST_INDEX => MONTH_TYPE, + FIRST_INDEX_LENGTH => 12, + FIRST_TEST_VALUE => AUG, + SECOND_INDEX => SHORT_RANGE, + SECOND_INDEX_LENGTH => SHORT_LENGTH, + SECOND_TEST_VALUE => -7, + THIRD_INDEX => BOOLEAN, + THIRD_INDEX_LENGTH => 2, + THIRD_TEST_VALUE => FALSE, + FIRST_COMPONENT_TYPE => DATE, + FIRST_DEFAULT_VALUE => TODAY, + SECOND_DEFAULT_VALUE => FIRST_DATE, + SECOND_COMPONENT_TYPE => MONTH_TYPE, + THIRD_DEFAULT_VALUE => JAN, + FOURTH_DEFAULT_VALUE => DEC) ; + + FUNCTION NEW_FUNC_ARRAY_ATT_TEST IS NEW FUNC_ARRAY_ATT_TEST ( + FIRST_INDEX => DAY_TYPE, + FIRST_INDEX_LENGTH => 31, + FIRST_TEST_VALUE => 25, + SECOND_INDEX => SHORT_RANGE, + SECOND_INDEX_LENGTH => SHORT_LENGTH, + SECOND_TEST_VALUE => -7, + THIRD_INDEX => MID_YEAR, + THIRD_INDEX_LENGTH => 4, + THIRD_TEST_VALUE => JUL, + FIRST_COMPONENT_TYPE => DATE, + FIRST_DEFAULT_VALUE => TODAY, + SECOND_DEFAULT_VALUE => FIRST_DATE, + SECOND_COMPONENT_TYPE => MONTH_TYPE, + THIRD_DEFAULT_VALUE => JAN, + FOURTH_DEFAULT_VALUE => DEC) ; + + BEGIN -- LOCAL_BLOCK + + NEW_PROC_ARRAY_ATT_TEST ; + + DUMMY := NEW_FUNC_ARRAY_ATT_TEST ; + IF NOT DUMMY THEN + REPORT.FAILED ("WRONG VALUE RETURNED BY FUNCTION.") ; + END IF ; + + END LOCAL_BLOCK ; + + REPORT.RESULT ; + +END C36204D ; diff --git a/gcc-4.9/gcc/testsuite/ada/acats/tests/c3/c36205a.ada b/gcc-4.9/gcc/testsuite/ada/acats/tests/c3/c36205a.ada new file mode 100644 index 000000000..8c1f683be --- /dev/null +++ b/gcc-4.9/gcc/testsuite/ada/acats/tests/c3/c36205a.ada @@ -0,0 +1,212 @@ +-- C36205A.ADA + +-- Grant of Unlimited Rights +-- +-- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687, +-- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained +-- unlimited rights in the software and documentation contained herein. +-- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making +-- this public release, the Government intends to confer upon all +-- recipients unlimited rights equal to those held by the Government. +-- These rights include rights to use, duplicate, release or disclose the +-- released technical data and computer software in whole or in part, in +-- any manner and for any purpose whatsoever, and to have or permit others +-- to do so. +-- +-- DISCLAIMER +-- +-- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR +-- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED +-- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF 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 ATTRIBUTES GIVE THE CORRECT VALUES FOR +-- UNCONSTRAINED FORMAL PARAMETERS. + +-- BASIC CHECKS OF ARRAY OBJECTS AND WHOLE ARRAYS PASSED AS +-- PARAMETERS + +-- DAT 2/17/81 +-- JBG 9/11/81 +-- JWC 6/28/85 RENAMED TO -AB + +WITH REPORT; +PROCEDURE C36205A IS + + USE REPORT; + + TYPE I_A IS ARRAY (INTEGER RANGE <> ) OF INTEGER; + TYPE I_A_2 IS ARRAY (INTEGER RANGE <> , + INTEGER RANGE <> ) OF INTEGER; + A10 : I_A (1 .. 10); + A20 : I_A (18 .. 20); + I10 : INTEGER := IDENT_INT (10); + A2_10 : I_A_2 (1 .. I10, 3+I10 .. I10+I10); -- 1..10, 13..20 + A2_20 : I_A_2 (11 .. 3*I10, I10+11 .. I10+I10); -- 11..30, 21..20 + SUBTYPE STR IS STRING; + ALF : CONSTANT STR(IDENT_INT(1)..IDENT_INT(5)) := "ABCDE"; + ARF : STR(5 .. 9) := ALF; + + PROCEDURE P1 (A : I_A; FIR, LAS: INTEGER; S : STRING) IS + BEGIN + IF A'FIRST /= FIR + OR A'FIRST(1) /= FIR + THEN + FAILED ("'FIRST IS WRONG " & S); + END IF; + + IF A'LAST /= LAS + OR A'LAST(1) /= LAS + THEN + FAILED ("'LAST IS WRONG " & S); + END IF; + + IF A'LENGTH /= LAS - FIR + 1 + OR A'LENGTH /= A'LENGTH(1) + THEN + FAILED ("'LENGTH IS WRONG " & S); + END IF; + + IF (LAS NOT IN A'RANGE AND LAS >= FIR) + OR (FIR NOT IN A'RANGE AND LAS >= FIR) + OR FIR - 1 IN A'RANGE + OR LAS + 1 IN A'RANGE(1) + THEN + FAILED ("'RANGE IS WRONG " & S); + END IF; + + END P1; + + PROCEDURE P2 (A : I_A_2; F1,L1,F2,L2 : INTEGER; S : STRING) IS + BEGIN + IF A'FIRST /= A'FIRST(1) + OR A'FIRST /= F1 + THEN + FAILED ("'FIRST(1) IS WRONG " & S); + END IF; + + IF A'LAST(1) /= L1 THEN + FAILED ("'LAST(1) IS WRONG " & S); + END IF; + + IF A'LENGTH(1) /= A'LENGTH + OR A'LENGTH /= L1 - F1 + 1 + THEN + FAILED ("'LENGTH(1) IS WRONG " & S); + END IF; + + IF F1 - 1 IN A'RANGE + OR (F1 NOT IN A'RANGE AND F1 <= L1) + OR (L1 NOT IN A'RANGE(1) AND F1 <= L1) + OR L1 + 1 IN A'RANGE(1) + THEN + FAILED ("'RANGE(1) IS WRONG " & S); + END IF; + + IF A'FIRST(2) /= F2 THEN + FAILED ("'FIRST(2) IS WRONG " & S); + END IF; + + IF A'LAST(2) /= L2 THEN + FAILED ("'LAST(2) IS WRONG " & S); + END IF; + + IF L2 - F2 /= A'LENGTH(2) - 1 THEN + FAILED ("'LENGTH(2) IS WRONG " & S); + END IF; + + IF F2 - 1 IN A'RANGE(2) + OR (F2 NOT IN A'RANGE(2) AND A'LENGTH(2) > 0) + OR (L2 NOT IN A'RANGE(2) AND A'LENGTH(2) /= 0) + OR L2 + 1 IN A'RANGE(2) + THEN + FAILED ("'RANGE(2) IS WRONG " & S); + END IF; + END P2; + + PROCEDURE S1 (S:STR; F,L:INTEGER; MESS:STRING) IS + BEGIN + IF S'FIRST /= F THEN + FAILED ("STRING 'FIRST IS WRONG " & MESS); + END IF; + + IF S'LAST(1) /= L THEN + FAILED ("STRING 'LAST IS WRONG " & MESS); + END IF; + + IF S'LENGTH /= L - F + 1 + OR S'LENGTH(1) /= S'LENGTH + THEN + FAILED ("STRING 'LENGTH IS WRONG " & MESS); + END IF; + + IF (F <= L AND + (F NOT IN S'RANGE + OR L NOT IN S'RANGE + OR F NOT IN S'RANGE(1) + OR L NOT IN S'RANGE(1))) + OR F - 1 IN S'RANGE + OR L + 1 IN S'RANGE(1) + THEN + FAILED ("STRING 'RANGE IS WRONG " & MESS); + END IF; + END S1; + +BEGIN + TEST ( "C36205A", "CHECKING ATTRIBUTE VALUES POSSESSED BY FORMAL "& + "PARAMETERS WHOSE ACTUALS ARE UNCONSTRAINED " & + "ARRAYS - BASIC CHECKS"); + + IF A10'FIRST /= 1 + OR A2_10'FIRST(1) /= 1 + OR A2_10'FIRST(2) /= IDENT_INT(13) + OR A2_20'FIRST /= 11 + OR A2_20'FIRST(2) /= 21 + THEN + FAILED ("'FIRST FOR OBJECTS IS WRONG"); + END IF; + + + IF A10'LAST(1) /= 10 + OR A2_10'LAST /= 10 + OR A2_10'LAST(2) /= 20 + OR A2_20'LAST(1) /= 30 + OR A2_20'LAST(2) /= IDENT_INT(20) + THEN + FAILED ("'LAST FOR OBJECTS IS WRONG"); + END IF; + IF A10'LENGTH /= IDENT_INT(10) + OR A2_10'LENGTH(1) /= 10 + OR A2_10'LENGTH(2) /= IDENT_INT(8) + OR A2_20'LENGTH /= 20 + OR A2_20'LENGTH(2) /= IDENT_INT(0) + THEN + FAILED ("'LENGTH FOR OBJECTS IS WRONG"); + END IF; + + IF 0 IN A10'RANGE + OR IDENT_INT(11) IN A10'RANGE(1) + OR IDENT_INT(0) IN A2_10'RANGE(1) + OR 11 IN A2_10'RANGE + OR 12 IN A2_10'RANGE(2) + OR IDENT_INT(21) IN A2_10'RANGE(2) + OR 10 IN A2_20'RANGE + OR IDENT_INT(31) IN A2_20'RANGE(1) + OR IDENT_INT(20) IN A2_20'RANGE(2) + OR 0 IN A2_20'RANGE(2) + THEN + FAILED ("'RANGE FOR OBJECTS IS WRONG"); + END IF; + + P1 (A10, 1, 10, "P1 1"); + P1 (A20, 18, 20, "P1 A20"); + P2(A2_10, 1, 10, 13, 20, "P2 1"); + P2 (A2_20, 11, 30, 21, 20, "P2 2"); + S1 (ALF, 1, 5, "X0"); + S1 (ARF, 5, 9, "ARF1"); + + RESULT; + +END C36205A; diff --git a/gcc-4.9/gcc/testsuite/ada/acats/tests/c3/c36205b.ada b/gcc-4.9/gcc/testsuite/ada/acats/tests/c3/c36205b.ada new file mode 100644 index 000000000..b29816ca1 --- /dev/null +++ b/gcc-4.9/gcc/testsuite/ada/acats/tests/c3/c36205b.ada @@ -0,0 +1,169 @@ +-- C36205B.ADA + +-- Grant of Unlimited Rights +-- +-- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687, +-- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained +-- unlimited rights in the software and documentation contained herein. +-- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making +-- this public release, the Government intends to confer upon all +-- recipients unlimited rights equal to those held by the Government. +-- These rights include rights to use, duplicate, release or disclose the +-- released technical data and computer software in whole or in part, in +-- any manner and for any purpose whatsoever, and to have or permit others +-- to do so. +-- +-- DISCLAIMER +-- +-- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR +-- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED +-- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF 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 ATTRIBUTES GIVE THE CORRECT VALUES FOR +-- UNCONSTRAINED FORMAL PARAMETERS. + +-- ATTRIBUTES OF NON-NULL STATIC SLICES + +-- DAT 2/17/81 +-- JBG 9/11/81 +-- JWC 6/28/85 RENAMED TO -AB + +WITH REPORT; +PROCEDURE C36205B IS + + USE REPORT; + + TYPE I_A IS ARRAY (INTEGER RANGE <> ) OF INTEGER; + TYPE I_A_2 IS ARRAY (INTEGER RANGE <> , + INTEGER RANGE <> ) OF INTEGER; + A10 : I_A (1 .. 10); + A20 : I_A (18 .. 20); + I10 : INTEGER := IDENT_INT (10); + A2_10 : I_A_2 (1 .. I10, 3+I10 .. I10*I10); -- 1..10, 13..20 + A2_20 : I_A_2 (11 .. 3*I10, I10+11 .. I10+I10); -- 11..30, 21..20 + SUBTYPE STR IS STRING; + ALF : CONSTANT STR(IDENT_INT(1)..IDENT_INT(5)) := "ABCDE"; + ARF : STR(5 .. 9) := ALF; + + PROCEDURE P1 (A : I_A; FIR, LAS: INTEGER; S : STRING) IS + BEGIN + IF A'FIRST /= FIR + OR A'FIRST(1) /= FIR + THEN + FAILED ("'FIRST IS WRONG " & S); + END IF; + + IF A'LAST /= LAS + OR A'LAST(1) /= LAS + THEN + FAILED ("'LAST IS WRONG " & S); + END IF; + + IF A'LENGTH /= LAS - FIR + 1 + OR A'LENGTH /= A'LENGTH(1) + THEN + FAILED ("'LENGTH IS WRONG " & S); + END IF; + + IF (LAS NOT IN A'RANGE AND LAS >= FIR) + OR (FIR NOT IN A'RANGE AND LAS >= FIR) + OR FIR - 1 IN A'RANGE + OR LAS + 1 IN A'RANGE(1) + THEN + FAILED ("'RANGE IS WRONG " & S); + END IF; + + END P1; + + PROCEDURE P2 (A : I_A_2; F1,L1,F2,L2 : INTEGER; S : STRING) IS + BEGIN + IF A'FIRST /= A'FIRST(1) + OR A'FIRST /= F1 + THEN + FAILED ("'FIRST(1) IS WRONG " & S); + END IF; + + IF A'LAST(1) /= L1 THEN + FAILED ("'LAST(1) IS WRONG " & S); + END IF; + + IF A'LENGTH(1) /= A'LENGTH + OR A'LENGTH /= L1 - F1 + 1 + THEN + FAILED ("'LENGTH(1) IS WRONG " & S); + END IF; + + IF F1 - 1 IN A'RANGE + OR (F1 NOT IN A'RANGE AND F1 <= L1) + OR (L1 NOT IN A'RANGE(1) AND F1 <= L1) + OR L1 + 1 IN A'RANGE(1) + THEN + FAILED ("'RANGE(1) IS WRONG " & S); + END IF; + + IF A'FIRST(2) /= F2 THEN + FAILED ("'FIRST(2) IS WRONG " & S); + END IF; + + IF A'LAST(2) /= L2 THEN + FAILED ("'LAST(2) IS WRONG " & S); + END IF; + + IF L2 - F2 /= A'LENGTH(2) - 1 THEN + FAILED ("'LENGTH(2) IS WRONG " & S); + END IF; + + IF F2 - 1 IN A'RANGE(2) + OR (F2 NOT IN A'RANGE(2) AND A'LENGTH(2) > 0) + OR (L2 NOT IN A'RANGE(2) AND A'LENGTH(2) /= 0) + OR L2 + 1 IN A'RANGE(2) + THEN + FAILED ("'RANGE(2) IS WRONG " & S); + END IF; + END P2; + + PROCEDURE S1 (S:STR; F,L:INTEGER; MESS:STRING) IS + BEGIN + IF S'FIRST /= F THEN + FAILED ("STRING 'FIRST IS WRONG " & MESS); + END IF; + + IF S'LAST(1) /= L THEN + FAILED ("STRING 'LAST IS WRONG " & MESS); + END IF; + + IF S'LENGTH /= L - F + 1 + OR S'LENGTH(1) /= S'LENGTH + THEN + FAILED ("STRING 'LENGTH IS WRONG " & MESS); + END IF; + + IF (F <= L AND + (F NOT IN S'RANGE + OR L NOT IN S'RANGE + OR F NOT IN S'RANGE(1) + OR L NOT IN S'RANGE(1))) + OR F - 1 IN S'RANGE + OR L + 1 IN S'RANGE(1) + THEN + FAILED ("STRING 'RANGE IS WRONG " & MESS); + END IF; + END S1; + +BEGIN + TEST ( "C36205B", "CHECKING ATTRIBUTE VALUES POSSESSED BY FORMAL "& + "PARAMETERS WHOSE ACTUALS ARE UNCONSTRAINED " & + "ARRAYS - NON-NULL STATIC SLICES"); + + P1 (A10(1 .. 10), 1, 10, "P1 2"); + P1 (A10(1..9), 1, 9, "P1 3"); + P1 (A10(2..10), 2, 10, "P1 4"); + P1 (A10 (2..9), 2, 9, "P1 5"); + P1 (A10 (4 .. 5), 4, 5, "P1 6"); + P1 (A10 (5 .. 5), 5, 5, "P1 7"); + + RESULT; +END C36205B; diff --git a/gcc-4.9/gcc/testsuite/ada/acats/tests/c3/c36205c.ada b/gcc-4.9/gcc/testsuite/ada/acats/tests/c3/c36205c.ada new file mode 100644 index 000000000..b11363baa --- /dev/null +++ b/gcc-4.9/gcc/testsuite/ada/acats/tests/c3/c36205c.ada @@ -0,0 +1,165 @@ +-- C36205C.ADA + +-- Grant of Unlimited Rights +-- +-- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687, +-- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained +-- unlimited rights in the software and documentation contained herein. +-- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making +-- this public release, the Government intends to confer upon all +-- recipients unlimited rights equal to those held by the Government. +-- These rights include rights to use, duplicate, release or disclose the +-- released technical data and computer software in whole or in part, in +-- any manner and for any purpose whatsoever, and to have or permit others +-- to do so. +-- +-- DISCLAIMER +-- +-- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR +-- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED +-- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF 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 ATTRIBUTES GIVE THE CORRECT VALUES FOR +-- UNCONSTRAINED FORMAL PARAMETERS. + +-- ATTRIBUTES OF NON-NULL DYNAMIC SLICES + +-- DAT 2/17/81 +-- JBG 9/11/81 +-- JWC 6/28/85 RENAMED TO -AB + +WITH REPORT; +PROCEDURE C36205C IS + + USE REPORT; + + TYPE I_A IS ARRAY (INTEGER RANGE <> ) OF INTEGER; + TYPE I_A_2 IS ARRAY (INTEGER RANGE <> , + INTEGER RANGE <> ) OF INTEGER; + A10 : I_A (1 .. 10); + A20 : I_A (18 .. 20); + I10 : INTEGER := IDENT_INT (10); + A2_10 : I_A_2 (1 .. I10, 3+I10 .. I10*I10); -- 1..10, 13..20 + A2_20 : I_A_2 (11 .. 3*I10, I10+11 .. I10+I10); -- 11..30, 21..20 + SUBTYPE STR IS STRING; + ALF : CONSTANT STR(IDENT_INT(1)..IDENT_INT(5)) := "ABCDE"; + ARF : STR(5 .. 9) := ALF; + + PROCEDURE P1 (A : I_A; FIR, LAS: INTEGER; S : STRING) IS + BEGIN + IF A'FIRST /= FIR + OR A'FIRST(1) /= FIR + THEN + FAILED ("'FIRST IS WRONG " & S); + END IF; + + IF A'LAST /= LAS + OR A'LAST(1) /= LAS + THEN + FAILED ("'LAST IS WRONG " & S); + END IF; + + IF A'LENGTH /= LAS - FIR + 1 + OR A'LENGTH /= A'LENGTH(1) + THEN + FAILED ("'LENGTH IS WRONG " & S); + END IF; + + IF (LAS NOT IN A'RANGE AND LAS >= FIR) + OR (FIR NOT IN A'RANGE AND LAS >= FIR) + OR FIR - 1 IN A'RANGE + OR LAS + 1 IN A'RANGE(1) + THEN + FAILED ("'RANGE IS WRONG " & S); + END IF; + + END P1; + + PROCEDURE P2 (A : I_A_2; F1,L1,F2,L2 : INTEGER; S : STRING) IS + BEGIN + IF A'FIRST /= A'FIRST(1) + OR A'FIRST /= F1 + THEN + FAILED ("'FIRST(1) IS WRONG " & S); + END IF; + + IF A'LAST(1) /= L1 THEN + FAILED ("'LAST(1) IS WRONG " & S); + END IF; + + IF A'LENGTH(1) /= A'LENGTH + OR A'LENGTH /= L1 - F1 + 1 + THEN + FAILED ("'LENGTH(1) IS WRONG " & S); + END IF; + + IF F1 - 1 IN A'RANGE + OR (F1 NOT IN A'RANGE AND F1 <= L1) + OR (L1 NOT IN A'RANGE(1) AND F1 <= L1) + OR L1 + 1 IN A'RANGE(1) + THEN + FAILED ("'RANGE(1) IS WRONG " & S); + END IF; + + IF A'FIRST(2) /= F2 THEN + FAILED ("'FIRST(2) IS WRONG " & S); + END IF; + + IF A'LAST(2) /= L2 THEN + FAILED ("'LAST(2) IS WRONG " & S); + END IF; + + IF L2 - F2 /= A'LENGTH(2) - 1 THEN + FAILED ("'LENGTH(2) IS WRONG " & S); + END IF; + + IF F2 - 1 IN A'RANGE(2) + OR (F2 NOT IN A'RANGE(2) AND A'LENGTH(2) > 0) + OR (L2 NOT IN A'RANGE(2) AND A'LENGTH(2) /= 0) + OR L2 + 1 IN A'RANGE(2) + THEN + FAILED ("'RANGE(2) IS WRONG " & S); + END IF; + END P2; + + PROCEDURE S1 (S:STR; F,L:INTEGER; MESS:STRING) IS + BEGIN + IF S'FIRST /= F THEN + FAILED ("STRING 'FIRST IS WRONG " & MESS); + END IF; + + IF S'LAST(1) /= L THEN + FAILED ("STRING 'LAST IS WRONG " & MESS); + END IF; + + IF S'LENGTH /= L - F + 1 + OR S'LENGTH(1) /= S'LENGTH + THEN + FAILED ("STRING 'LENGTH IS WRONG " & MESS); + END IF; + + IF (F <= L AND + (F NOT IN S'RANGE + OR L NOT IN S'RANGE + OR F NOT IN S'RANGE(1) + OR L NOT IN S'RANGE(1))) + OR F - 1 IN S'RANGE + OR L + 1 IN S'RANGE(1) + THEN + FAILED ("STRING 'RANGE IS WRONG " & MESS); + END IF; + END S1; + +BEGIN + TEST ( "C36205C", "CHECKING ATTRIBUTE VALUES POSSESSED BY FORMAL "& + "PARAMETERS WHOSE ACTUALS ARE UNCONSTRAINED " & + "ARRAYS - NON-NULL DYNAMIC SLICES"); + + P1 (A10 (I10..I10), 10, 10, "P1 8"); + P1 (A10 (I10 - 9 .. I10), 1, 10, "P1 9"); + + RESULT; +END C36205C; diff --git a/gcc-4.9/gcc/testsuite/ada/acats/tests/c3/c36205d.ada b/gcc-4.9/gcc/testsuite/ada/acats/tests/c3/c36205d.ada new file mode 100644 index 000000000..f03f75dd0 --- /dev/null +++ b/gcc-4.9/gcc/testsuite/ada/acats/tests/c3/c36205d.ada @@ -0,0 +1,180 @@ +-- C36205D.ADA + +-- Grant of Unlimited Rights +-- +-- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687, +-- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained +-- unlimited rights in the software and documentation contained herein. +-- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making +-- this public release, the Government intends to confer upon all +-- recipients unlimited rights equal to those held by the Government. +-- These rights include rights to use, duplicate, release or disclose the +-- released technical data and computer software in whole or in part, in +-- any manner and for any purpose whatsoever, and to have or permit others +-- to do so. +-- +-- DISCLAIMER +-- +-- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR +-- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED +-- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF 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 ATTRIBUTES GIVE THE CORRECT VALUES FOR +-- UNCONSTRAINED FORMAL PARAMETERS. + +-- ATTRIBUTES OF NULL STATIC SLICES + +-- DAT 2/17/81 +-- JBG 9/11/81 +-- JWC 6/28/85 RENAMED TO -AB + +WITH REPORT; +PROCEDURE C36205D IS + + USE REPORT; + + TYPE I_A IS ARRAY (INTEGER RANGE <> ) OF INTEGER; + TYPE I_A_2 IS ARRAY (INTEGER RANGE <> , + INTEGER RANGE <> ) OF INTEGER; + A10 : I_A (1 .. 10); + A20 : I_A (18 .. 20); + I10 : INTEGER := IDENT_INT (10); + A2_10 : I_A_2 (1 .. I10, 3+I10 .. I10*I10); -- 1..10, 13..20 + A2_20 : I_A_2 (11 .. 3*I10, I10+11 .. I10+I10); -- 11..30, 21..20 + SUBTYPE STR IS STRING; + ALF : CONSTANT STR(IDENT_INT(1)..IDENT_INT(5)) := "ABCDE"; + ARF : STR(5 .. 9) := ALF; + + PROCEDURE P1 (A : I_A; FIR, LAS: INTEGER; S : STRING) IS + BEGIN + IF A'FIRST /= FIR + OR A'FIRST(1) /= FIR + THEN + FAILED ("'FIRST IS WRONG " & S); + END IF; + + IF A'LAST /= LAS + OR A'LAST(1) /= LAS + THEN + FAILED ("'LAST IS WRONG " & S); + END IF; + + IF A'LENGTH /= LAS - FIR + 1 + OR A'LENGTH /= A'LENGTH(1) + THEN + FAILED ("'LENGTH IS WRONG " & S); + END IF; + + IF (LAS NOT IN A'RANGE AND LAS >= FIR) + OR (FIR NOT IN A'RANGE AND LAS >= FIR) + OR FIR - 1 IN A'RANGE + OR LAS + 1 IN A'RANGE(1) + THEN + FAILED ("'RANGE IS WRONG " & S); + END IF; + + END P1; + + PROCEDURE P2 (A : I_A_2; F1,L1,F2,L2 : INTEGER; S : STRING) IS + BEGIN + IF A'FIRST /= A'FIRST(1) + OR A'FIRST /= F1 + THEN + FAILED ("'FIRST(1) IS WRONG " & S); + END IF; + + IF A'LAST(1) /= L1 THEN + FAILED ("'LAST(1) IS WRONG " & S); + END IF; + + IF A'LENGTH(1) /= A'LENGTH + OR A'LENGTH /= L1 - F1 + 1 + THEN + FAILED ("'LENGTH(1) IS WRONG " & S); + END IF; + + IF F1 - 1 IN A'RANGE + OR (F1 NOT IN A'RANGE AND F1 <= L1) + OR (L1 NOT IN A'RANGE(1) AND F1 <= L1) + OR L1 + 1 IN A'RANGE(1) + THEN + FAILED ("'RANGE(1) IS WRONG " & S); + END IF; + + IF A'FIRST(2) /= F2 THEN + FAILED ("'FIRST(2) IS WRONG " & S); + END IF; + + IF A'LAST(2) /= L2 THEN + FAILED ("'LAST(2) IS WRONG " & S); + END IF; + + IF L2 - F2 /= A'LENGTH(2) - 1 THEN + FAILED ("'LENGTH(2) IS WRONG " & S); + END IF; + + IF F2 - 1 IN A'RANGE(2) + OR (F2 NOT IN A'RANGE(2) AND A'LENGTH(2) > 0) + OR (L2 NOT IN A'RANGE(2) AND A'LENGTH(2) /= 0) + OR L2 + 1 IN A'RANGE(2) + THEN + FAILED ("'RANGE(2) IS WRONG " & S); + END IF; + END P2; + + PROCEDURE S1 (S:STR; F,L:INTEGER; MESS:STRING) IS + BEGIN + IF S'FIRST /= F THEN + FAILED ("STRING 'FIRST IS WRONG " & MESS); + END IF; + + IF S'LAST(1) /= L THEN + FAILED ("STRING 'LAST IS WRONG " & MESS); + END IF; + + IF S'LENGTH /= L - F + 1 + OR S'LENGTH(1) /= S'LENGTH + THEN + FAILED ("STRING 'LENGTH IS WRONG " & MESS); + END IF; + + IF (F <= L AND + (F NOT IN S'RANGE + OR L NOT IN S'RANGE + OR F NOT IN S'RANGE(1) + OR L NOT IN S'RANGE(1))) + OR F - 1 IN S'RANGE + OR L + 1 IN S'RANGE(1) + THEN + FAILED ("STRING 'RANGE IS WRONG " & MESS); + END IF; + END S1; + +BEGIN + TEST ( "C36205D", "CHECKING ATTRIBUTE VALUES POSSESSED BY FORMAL "& + "PARAMETERS WHOSE ACTUALS ARE UNCONSTRAINED " & + "ARRAYS - NULL STATIC SLICES"); + + P1 (A10 (1 .. 0), 1, 0, "P1 11"); + P1 (A10 (2 .. 1), 2, 1, "P1 12"); + + P1 (A10, 1, 10, "P1 1"); + P1 (A10(1 .. 10), 1, 10, "P1 2"); + P1 (A10(1..9), 1, 9, "P1 3"); + P1 (A10(2..10), 2, 10, "P1 4"); + P1 (A10 (2..9), 2, 9, "P1 5"); + P1 (A10 (4 .. 5), 4, 5, "P1 6"); + P1 (A10 (5 .. 5), 5, 5, "P1 7"); + P1 (A10 (I10..I10), 10, 10, "P1 8"); + P1 (A10 (I10 - 9 .. I10), 1, 10, "P1 9"); + P1 (A10 (I10 .. I10 - 1), 10, 9, "P1 10"); + P1 (A10 (9 .. 10), 9, 10, "P1 13"); + P1 (A10 (10 .. 9), 10, 9, "P1 14"); + P1 (A10 (9 .. I10 - 1), 9, 9, "P1 15"); + P1 (A10 (9 .. 8), 9, 8, "P1 16"); + + RESULT; +END C36205D; diff --git a/gcc-4.9/gcc/testsuite/ada/acats/tests/c3/c36205e.ada b/gcc-4.9/gcc/testsuite/ada/acats/tests/c3/c36205e.ada new file mode 100644 index 000000000..f165a2894 --- /dev/null +++ b/gcc-4.9/gcc/testsuite/ada/acats/tests/c3/c36205e.ada @@ -0,0 +1,164 @@ +-- C36205E.ADA + +-- Grant of Unlimited Rights +-- +-- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687, +-- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained +-- unlimited rights in the software and documentation contained herein. +-- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making +-- this public release, the Government intends to confer upon all +-- recipients unlimited rights equal to those held by the Government. +-- These rights include rights to use, duplicate, release or disclose the +-- released technical data and computer software in whole or in part, in +-- any manner and for any purpose whatsoever, and to have or permit others +-- to do so. +-- +-- DISCLAIMER +-- +-- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR +-- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED +-- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF 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 ATTRIBUTES GIVE THE CORRECT VALUES FOR +-- UNCONSTRAINED FORMAL PARAMETERS. + +-- ATTRIBUTES OF DYNAMIC NULL SLICES + +-- DAT 2/17/81 +-- JBG 9/11/81 +-- JWC 6/28/85 RENAMED TO -AB + +WITH REPORT; +PROCEDURE C36205E IS + + USE REPORT; + + TYPE I_A IS ARRAY (INTEGER RANGE <> ) OF INTEGER; + TYPE I_A_2 IS ARRAY (INTEGER RANGE <> , + INTEGER RANGE <> ) OF INTEGER; + A10 : I_A (1 .. 10); + A20 : I_A (18 .. 20); + I10 : INTEGER := IDENT_INT (10); + A2_10 : I_A_2 (1 .. I10, 3+I10 .. I10*I10); -- 1..10, 13..20 + A2_20 : I_A_2 (11 .. 3*I10, I10+11 .. I10+I10); -- 11..30, 21..20 + SUBTYPE STR IS STRING; + ALF : CONSTANT STR(IDENT_INT(1)..IDENT_INT(5)) := "ABCDE"; + ARF : STR(5 .. 9) := ALF; + + PROCEDURE P1 (A : I_A; FIR, LAS: INTEGER; S : STRING) IS + BEGIN + IF A'FIRST /= FIR + OR A'FIRST(1) /= FIR + THEN + FAILED ("'FIRST IS WRONG " & S); + END IF; + + IF A'LAST /= LAS + OR A'LAST(1) /= LAS + THEN + FAILED ("'LAST IS WRONG " & S); + END IF; + + IF A'LENGTH /= LAS - FIR + 1 + OR A'LENGTH /= A'LENGTH(1) + THEN + FAILED ("'LENGTH IS WRONG " & S); + END IF; + + IF (LAS NOT IN A'RANGE AND LAS >= FIR) + OR (FIR NOT IN A'RANGE AND LAS >= FIR) + OR FIR - 1 IN A'RANGE + OR LAS + 1 IN A'RANGE(1) + THEN + FAILED ("'RANGE IS WRONG " & S); + END IF; + + END P1; + + PROCEDURE P2 (A : I_A_2; F1,L1,F2,L2 : INTEGER; S : STRING) IS + BEGIN + IF A'FIRST /= A'FIRST(1) + OR A'FIRST /= F1 + THEN + FAILED ("'FIRST(1) IS WRONG " & S); + END IF; + + IF A'LAST(1) /= L1 THEN + FAILED ("'LAST(1) IS WRONG " & S); + END IF; + + IF A'LENGTH(1) /= A'LENGTH + OR A'LENGTH /= L1 - F1 + 1 + THEN + FAILED ("'LENGTH(1) IS WRONG " & S); + END IF; + + IF F1 - 1 IN A'RANGE + OR (F1 NOT IN A'RANGE AND F1 <= L1) + OR (L1 NOT IN A'RANGE(1) AND F1 <= L1) + OR L1 + 1 IN A'RANGE(1) + THEN + FAILED ("'RANGE(1) IS WRONG " & S); + END IF; + + IF A'FIRST(2) /= F2 THEN + FAILED ("'FIRST(2) IS WRONG " & S); + END IF; + + IF A'LAST(2) /= L2 THEN + FAILED ("'LAST(2) IS WRONG " & S); + END IF; + + IF L2 - F2 /= A'LENGTH(2) - 1 THEN + FAILED ("'LENGTH(2) IS WRONG " & S); + END IF; + + IF F2 - 1 IN A'RANGE(2) + OR (F2 NOT IN A'RANGE(2) AND A'LENGTH(2) > 0) + OR (L2 NOT IN A'RANGE(2) AND A'LENGTH(2) /= 0) + OR L2 + 1 IN A'RANGE(2) + THEN + FAILED ("'RANGE(2) IS WRONG " & S); + END IF; + END P2; + + PROCEDURE S1 (S:STR; F,L:INTEGER; MESS:STRING) IS + BEGIN + IF S'FIRST /= F THEN + FAILED ("STRING 'FIRST IS WRONG " & MESS); + END IF; + + IF S'LAST(1) /= L THEN + FAILED ("STRING 'LAST IS WRONG " & MESS); + END IF; + + IF S'LENGTH /= L - F + 1 + OR S'LENGTH(1) /= S'LENGTH + THEN + FAILED ("STRING 'LENGTH IS WRONG " & MESS); + END IF; + + IF (F <= L AND + (F NOT IN S'RANGE + OR L NOT IN S'RANGE + OR F NOT IN S'RANGE(1) + OR L NOT IN S'RANGE(1))) + OR F - 1 IN S'RANGE + OR L + 1 IN S'RANGE(1) + THEN + FAILED ("STRING 'RANGE IS WRONG " & MESS); + END IF; + END S1; + +BEGIN + TEST ( "C36205E", "CHECKING ATTRIBUTE VALUES POSSESSED BY FORMAL "& + "PARAMETERS WHOSE ACTUALS ARE UNCONSTRAINED " & + "ARRAYS - DYNAMIC NULL SLICES"); + + P1 (A10 (I10 .. I10 - 1), 10, 9, "P1 10"); + + RESULT; +END C36205E; diff --git a/gcc-4.9/gcc/testsuite/ada/acats/tests/c3/c36205f.ada b/gcc-4.9/gcc/testsuite/ada/acats/tests/c3/c36205f.ada new file mode 100644 index 000000000..22e1c1602 --- /dev/null +++ b/gcc-4.9/gcc/testsuite/ada/acats/tests/c3/c36205f.ada @@ -0,0 +1,165 @@ +-- C36205F.ADA + +-- Grant of Unlimited Rights +-- +-- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687, +-- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained +-- unlimited rights in the software and documentation contained herein. +-- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making +-- this public release, the Government intends to confer upon all +-- recipients unlimited rights equal to those held by the Government. +-- These rights include rights to use, duplicate, release or disclose the +-- released technical data and computer software in whole or in part, in +-- any manner and for any purpose whatsoever, and to have or permit others +-- to do so. +-- +-- DISCLAIMER +-- +-- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR +-- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED +-- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF 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 ATTRIBUTES GIVE THE CORRECT VALUES FOR +-- UNCONSTRAINED FORMAL PARAMETERS. + +-- ATTRIBUTES OF STATIC NON-NULL AGGREGATES + +-- DAT 2/17/81 +-- JBG 9/11/81 +-- JWC 6/28/85 RENAMED TO -AB + +WITH REPORT; +PROCEDURE C36205F IS + + USE REPORT; + + TYPE I_A IS ARRAY (INTEGER RANGE <> ) OF INTEGER; + TYPE I_A_2 IS ARRAY (INTEGER RANGE <> , + INTEGER RANGE <> ) OF INTEGER; + A10 : I_A (1 .. 10); + A20 : I_A (18 .. 20); + I10 : INTEGER := IDENT_INT (10); + A2_10 : I_A_2 (1 .. I10, 3+I10 .. I10*I10); -- 1..10, 13..20 + A2_20 : I_A_2 (11 .. 3*I10, I10+11 .. I10+I10); -- 11..30, 21..20 + SUBTYPE STR IS STRING; + ALF : CONSTANT STR(IDENT_INT(1)..IDENT_INT(5)) := "ABCDE"; + ARF : STR(5 .. 9) := ALF; + + PROCEDURE P1 (A : I_A; FIR, LAS: INTEGER; S : STRING) IS + BEGIN + IF A'FIRST /= FIR + OR A'FIRST(1) /= FIR + THEN + FAILED ("'FIRST IS WRONG " & S); + END IF; + + IF A'LAST /= LAS + OR A'LAST(1) /= LAS + THEN + FAILED ("'LAST IS WRONG " & S); + END IF; + + IF A'LENGTH /= LAS - FIR + 1 + OR A'LENGTH /= A'LENGTH(1) + THEN + FAILED ("'LENGTH IS WRONG " & S); + END IF; + + IF (LAS NOT IN A'RANGE AND LAS >= FIR) + OR (FIR NOT IN A'RANGE AND LAS >= FIR) + OR FIR - 1 IN A'RANGE + OR LAS + 1 IN A'RANGE(1) + THEN + FAILED ("'RANGE IS WRONG " & S); + END IF; + + END P1; + + PROCEDURE P2 (A : I_A_2; F1,L1,F2,L2 : INTEGER; S : STRING) IS + BEGIN + IF A'FIRST /= A'FIRST(1) + OR A'FIRST /= F1 + THEN + FAILED ("'FIRST(1) IS WRONG " & S); + END IF; + + IF A'LAST(1) /= L1 THEN + FAILED ("'LAST(1) IS WRONG " & S); + END IF; + + IF A'LENGTH(1) /= A'LENGTH + OR A'LENGTH /= L1 - F1 + 1 + THEN + FAILED ("'LENGTH(1) IS WRONG " & S); + END IF; + + IF F1 - 1 IN A'RANGE + OR (F1 NOT IN A'RANGE AND F1 <= L1) + OR (L1 NOT IN A'RANGE(1) AND F1 <= L1) + OR L1 + 1 IN A'RANGE(1) + THEN + FAILED ("'RANGE(1) IS WRONG " & S); + END IF; + + IF A'FIRST(2) /= F2 THEN + FAILED ("'FIRST(2) IS WRONG " & S); + END IF; + + IF A'LAST(2) /= L2 THEN + FAILED ("'LAST(2) IS WRONG " & S); + END IF; + + IF L2 - F2 /= A'LENGTH(2) - 1 THEN + FAILED ("'LENGTH(2) IS WRONG " & S); + END IF; + + IF F2 - 1 IN A'RANGE(2) + OR (F2 NOT IN A'RANGE(2) AND A'LENGTH(2) > 0) + OR (L2 NOT IN A'RANGE(2) AND A'LENGTH(2) /= 0) + OR L2 + 1 IN A'RANGE(2) + THEN + FAILED ("'RANGE(2) IS WRONG " & S); + END IF; + END P2; + + PROCEDURE S1 (S:STR; F,L:INTEGER; MESS:STRING) IS + BEGIN + IF S'FIRST /= F THEN + FAILED ("STRING 'FIRST IS WRONG " & MESS); + END IF; + + IF S'LAST(1) /= L THEN + FAILED ("STRING 'LAST IS WRONG " & MESS); + END IF; + + IF S'LENGTH /= L - F + 1 + OR S'LENGTH(1) /= S'LENGTH + THEN + FAILED ("STRING 'LENGTH IS WRONG " & MESS); + END IF; + + IF (F <= L AND + (F NOT IN S'RANGE + OR L NOT IN S'RANGE + OR F NOT IN S'RANGE(1) + OR L NOT IN S'RANGE(1))) + OR F - 1 IN S'RANGE + OR L + 1 IN S'RANGE(1) + THEN + FAILED ("STRING 'RANGE IS WRONG " & MESS); + END IF; + END S1; + +BEGIN + TEST ( "C36205F", "CHECKING ATTRIBUTE VALUES POSSESSED BY FORMAL "& + "PARAMETERS WHOSE ACTUALS ARE UNCONSTRAINED " & + "ARRAYS - STATIC NON-NULL AGGREGATES"); + + P1 ((3 .. 5 => 2), 3, 5, "P1 16"); + P1 ((5 .. 5 => 5), 5, 5, "P1 17"); + + RESULT; +END C36205F; diff --git a/gcc-4.9/gcc/testsuite/ada/acats/tests/c3/c36205g.ada b/gcc-4.9/gcc/testsuite/ada/acats/tests/c3/c36205g.ada new file mode 100644 index 000000000..93f5a2e54 --- /dev/null +++ b/gcc-4.9/gcc/testsuite/ada/acats/tests/c3/c36205g.ada @@ -0,0 +1,165 @@ +-- C36205G.ADA + +-- Grant of Unlimited Rights +-- +-- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687, +-- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained +-- unlimited rights in the software and documentation contained herein. +-- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making +-- this public release, the Government intends to confer upon all +-- recipients unlimited rights equal to those held by the Government. +-- These rights include rights to use, duplicate, release or disclose the +-- released technical data and computer software in whole or in part, in +-- any manner and for any purpose whatsoever, and to have or permit others +-- to do so. +-- +-- DISCLAIMER +-- +-- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR +-- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED +-- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF 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 ATTRIBUTES GIVE THE CORRECT VALUES FOR +-- UNCONSTRAINED FORMAL PARAMETERS. + +-- ATTRIBUTES OF DYNAMIC NON-NULL AGGREGATES + +-- DAT 2/17/81 +-- JBG 9/11/81 +-- JWC 6/28/85 RENAMED TO -AB + +WITH REPORT; +PROCEDURE C36205G IS + + USE REPORT; + + TYPE I_A IS ARRAY (INTEGER RANGE <> ) OF INTEGER; + TYPE I_A_2 IS ARRAY (INTEGER RANGE <> , + INTEGER RANGE <> ) OF INTEGER; + A10 : I_A (1 .. 10); + A20 : I_A (18 .. 20); + I10 : INTEGER := IDENT_INT (10); + A2_10 : I_A_2 (1 .. I10, 3+I10 .. I10*I10); -- 1..10, 13..20 + A2_20 : I_A_2 (11 .. 3*I10, I10+11 .. I10+I10); -- 11..30, 21..20 + SUBTYPE STR IS STRING; + ALF : CONSTANT STR(IDENT_INT(1)..IDENT_INT(5)) := "ABCDE"; + ARF : STR(5 .. 9) := ALF; + + PROCEDURE P1 (A : I_A; FIR, LAS: INTEGER; S : STRING) IS + BEGIN + IF A'FIRST /= FIR + OR A'FIRST(1) /= FIR + THEN + FAILED ("'FIRST IS WRONG " & S); + END IF; + + IF A'LAST /= LAS + OR A'LAST(1) /= LAS + THEN + FAILED ("'LAST IS WRONG " & S); + END IF; + + IF A'LENGTH /= LAS - FIR + 1 + OR A'LENGTH /= A'LENGTH(1) + THEN + FAILED ("'LENGTH IS WRONG " & S); + END IF; + + IF (LAS NOT IN A'RANGE AND LAS >= FIR) + OR (FIR NOT IN A'RANGE AND LAS >= FIR) + OR FIR - 1 IN A'RANGE + OR LAS + 1 IN A'RANGE(1) + THEN + FAILED ("'RANGE IS WRONG " & S); + END IF; + + END P1; + + PROCEDURE P2 (A : I_A_2; F1,L1,F2,L2 : INTEGER; S : STRING) IS + BEGIN + IF A'FIRST /= A'FIRST(1) + OR A'FIRST /= F1 + THEN + FAILED ("'FIRST(1) IS WRONG " & S); + END IF; + + IF A'LAST(1) /= L1 THEN + FAILED ("'LAST(1) IS WRONG " & S); + END IF; + + IF A'LENGTH(1) /= A'LENGTH + OR A'LENGTH /= L1 - F1 + 1 + THEN + FAILED ("'LENGTH(1) IS WRONG " & S); + END IF; + + IF F1 - 1 IN A'RANGE + OR (F1 NOT IN A'RANGE AND F1 <= L1) + OR (L1 NOT IN A'RANGE(1) AND F1 <= L1) + OR L1 + 1 IN A'RANGE(1) + THEN + FAILED ("'RANGE(1) IS WRONG " & S); + END IF; + + IF A'FIRST(2) /= F2 THEN + FAILED ("'FIRST(2) IS WRONG " & S); + END IF; + + IF A'LAST(2) /= L2 THEN + FAILED ("'LAST(2) IS WRONG " & S); + END IF; + + IF L2 - F2 /= A'LENGTH(2) - 1 THEN + FAILED ("'LENGTH(2) IS WRONG " & S); + END IF; + + IF F2 - 1 IN A'RANGE(2) + OR (F2 NOT IN A'RANGE(2) AND A'LENGTH(2) > 0) + OR (L2 NOT IN A'RANGE(2) AND A'LENGTH(2) /= 0) + OR L2 + 1 IN A'RANGE(2) + THEN + FAILED ("'RANGE(2) IS WRONG " & S); + END IF; + END P2; + + PROCEDURE S1 (S:STR; F,L:INTEGER; MESS:STRING) IS + BEGIN + IF S'FIRST /= F THEN + FAILED ("STRING 'FIRST IS WRONG " & MESS); + END IF; + + IF S'LAST(1) /= L THEN + FAILED ("STRING 'LAST IS WRONG " & MESS); + END IF; + + IF S'LENGTH /= L - F + 1 + OR S'LENGTH(1) /= S'LENGTH + THEN + FAILED ("STRING 'LENGTH IS WRONG " & MESS); + END IF; + + IF (F <= L AND + (F NOT IN S'RANGE + OR L NOT IN S'RANGE + OR F NOT IN S'RANGE(1) + OR L NOT IN S'RANGE(1))) + OR F - 1 IN S'RANGE + OR L + 1 IN S'RANGE(1) + THEN + FAILED ("STRING 'RANGE IS WRONG " & MESS); + END IF; + END S1; + +BEGIN + TEST ( "C36205G", "CHECKING ATTRIBUTE VALUES POSSESSED BY FORMAL "& + "PARAMETERS WHOSE ACTUALS ARE UNCONSTRAINED " & + "ARRAYS - DYNAMIC NON-NULL AGGREGATES"); + + P1 ((IDENT_INT(3) .. IDENT_INT(5) => 2), 3, 5, "P1 16"); + P1 ((IDENT_INT(5) .. 5 => 5), 5, 5, "P1 17"); + + RESULT; +END C36205G; diff --git a/gcc-4.9/gcc/testsuite/ada/acats/tests/c3/c36205h.ada b/gcc-4.9/gcc/testsuite/ada/acats/tests/c3/c36205h.ada new file mode 100644 index 000000000..00303bc80 --- /dev/null +++ b/gcc-4.9/gcc/testsuite/ada/acats/tests/c3/c36205h.ada @@ -0,0 +1,166 @@ +-- C36205H.ADA + +-- Grant of Unlimited Rights +-- +-- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687, +-- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained +-- unlimited rights in the software and documentation contained herein. +-- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making +-- this public release, the Government intends to confer upon all +-- recipients unlimited rights equal to those held by the Government. +-- These rights include rights to use, duplicate, release or disclose the +-- released technical data and computer software in whole or in part, in +-- any manner and for any purpose whatsoever, and to have or permit others +-- to do so. +-- +-- DISCLAIMER +-- +-- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR +-- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED +-- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF 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 ATTRIBUTES GIVE THE CORRECT VALUES FOR +-- UNCONSTRAINED FORMAL PARAMETERS. + +-- ATTRIBUTES OF STATIC NULL AGGREGATES + +-- DAT 2/17/81 +-- JBG 9/11/81 +-- JWC 6/28/85 RENAMED TO -AB + +WITH REPORT; +PROCEDURE C36205H IS + + USE REPORT; + + TYPE I_A IS ARRAY (INTEGER RANGE <> ) OF INTEGER; + TYPE I_A_2 IS ARRAY (INTEGER RANGE <> , + INTEGER RANGE <> ) OF INTEGER; + A10 : I_A (1 .. 10); + A20 : I_A (18 .. 20); + I10 : INTEGER := IDENT_INT (10); + A2_10 : I_A_2 (1 .. I10, 3+I10 .. I10*I10); -- 1..10, 13..20 + A2_20 : I_A_2 (11 .. 3*I10, I10+11 .. I10+I10); -- 11..30, 21..20 + SUBTYPE STR IS STRING; + ALF : CONSTANT STR(IDENT_INT(1)..IDENT_INT(5)) := "ABCDE"; + ARF : STR(5 .. 9) := ALF; + + PROCEDURE P1 (A : I_A; FIR, LAS: INTEGER; S : STRING) IS + BEGIN + IF A'FIRST /= FIR + OR A'FIRST(1) /= FIR + THEN + FAILED ("'FIRST IS WRONG " & S); + END IF; + + IF A'LAST /= LAS + OR A'LAST(1) /= LAS + THEN + FAILED ("'LAST IS WRONG " & S); + END IF; + + IF A'LENGTH /= LAS - FIR + 1 + OR A'LENGTH /= A'LENGTH(1) + THEN + FAILED ("'LENGTH IS WRONG " & S); + END IF; + + IF (LAS NOT IN A'RANGE AND LAS >= FIR) + OR (FIR NOT IN A'RANGE AND LAS >= FIR) + OR FIR - 1 IN A'RANGE + OR LAS + 1 IN A'RANGE(1) + THEN + FAILED ("'RANGE IS WRONG " & S); + END IF; + + END P1; + + PROCEDURE P2 (A : I_A_2; F1,L1,F2,L2 : INTEGER; S : STRING) IS + BEGIN + IF A'FIRST /= A'FIRST(1) + OR A'FIRST /= F1 + THEN + FAILED ("'FIRST(1) IS WRONG " & S); + END IF; + + IF A'LAST(1) /= L1 THEN + FAILED ("'LAST(1) IS WRONG " & S); + END IF; + + IF A'LENGTH(1) /= A'LENGTH + OR A'LENGTH /= L1 - F1 + 1 + THEN + FAILED ("'LENGTH(1) IS WRONG " & S); + END IF; + + IF F1 - 1 IN A'RANGE + OR (F1 NOT IN A'RANGE AND F1 <= L1) + OR (L1 NOT IN A'RANGE(1) AND F1 <= L1) + OR L1 + 1 IN A'RANGE(1) + THEN + FAILED ("'RANGE(1) IS WRONG " & S); + END IF; + + IF A'FIRST(2) /= F2 THEN + FAILED ("'FIRST(2) IS WRONG " & S); + END IF; + + IF A'LAST(2) /= L2 THEN + FAILED ("'LAST(2) IS WRONG " & S); + END IF; + + IF L2 - F2 /= A'LENGTH(2) - 1 THEN + FAILED ("'LENGTH(2) IS WRONG " & S); + END IF; + + IF F2 - 1 IN A'RANGE(2) + OR (F2 NOT IN A'RANGE(2) AND A'LENGTH(2) > 0) + OR (L2 NOT IN A'RANGE(2) AND A'LENGTH(2) /= 0) + OR L2 + 1 IN A'RANGE(2) + THEN + FAILED ("'RANGE(2) IS WRONG " & S); + END IF; + END P2; + + PROCEDURE S1 (S:STR; F,L:INTEGER; MESS:STRING) IS + BEGIN + IF S'FIRST /= F THEN + FAILED ("STRING 'FIRST IS WRONG " & MESS); + END IF; + + IF S'LAST(1) /= L THEN + FAILED ("STRING 'LAST IS WRONG " & MESS); + END IF; + + IF S'LENGTH /= L - F + 1 + OR S'LENGTH(1) /= S'LENGTH + THEN + FAILED ("STRING 'LENGTH IS WRONG " & MESS); + END IF; + + IF (F <= L AND + (F NOT IN S'RANGE + OR L NOT IN S'RANGE + OR F NOT IN S'RANGE(1) + OR L NOT IN S'RANGE(1))) + OR F - 1 IN S'RANGE + OR L + 1 IN S'RANGE(1) + THEN + FAILED ("STRING 'RANGE IS WRONG " & MESS); + END IF; + END S1; + +BEGIN + TEST ( "C36205H", "CHECKING ATTRIBUTE VALUES POSSESSED BY FORMAL "& + "PARAMETERS WHOSE ACTUALS ARE UNCONSTRAINED " & + "ARRAYS - STATIC NULL AGGREGATES"); + + P1 ((5 .. 4 => 4), 5, 4, "P1 18"); + P1 ((1 .. 0 => 0), 1, 0, "P1 19"); + P1 ((-12 .. -13 => 3), -12, -13, "P1 21"); + + RESULT; +END C36205H; diff --git a/gcc-4.9/gcc/testsuite/ada/acats/tests/c3/c36205i.ada b/gcc-4.9/gcc/testsuite/ada/acats/tests/c3/c36205i.ada new file mode 100644 index 000000000..d61b3aa1c --- /dev/null +++ b/gcc-4.9/gcc/testsuite/ada/acats/tests/c3/c36205i.ada @@ -0,0 +1,167 @@ +-- C36205I.ADA + +-- Grant of Unlimited Rights +-- +-- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687, +-- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained +-- unlimited rights in the software and documentation contained herein. +-- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making +-- this public release, the Government intends to confer upon all +-- recipients unlimited rights equal to those held by the Government. +-- These rights include rights to use, duplicate, release or disclose the +-- released technical data and computer software in whole or in part, in +-- any manner and for any purpose whatsoever, and to have or permit others +-- to do so. +-- +-- DISCLAIMER +-- +-- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR +-- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED +-- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF 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 ATTRIBUTES GIVE THE CORRECT VALUES FOR +-- UNCONSTRAINED FORMAL PARAMETERS. + +-- ATTRIBUTES OF DYNAMIC NULL AGGREGATES + +-- DAT 2/17/81 +-- JBG 9/11/81 +-- JWC 6/28/85 RENAMED TO -AB + +WITH REPORT; +PROCEDURE C36205I IS + + USE REPORT; + + TYPE I_A IS ARRAY (INTEGER RANGE <> ) OF INTEGER; + TYPE I_A_2 IS ARRAY (INTEGER RANGE <> , + INTEGER RANGE <> ) OF INTEGER; + A10 : I_A (1 .. 10); + A20 : I_A (18 .. 20); + I10 : INTEGER := IDENT_INT (10); + A2_10 : I_A_2 (1 .. I10, 3+I10 .. I10*I10); -- 1..10, 13..20 + A2_20 : I_A_2 (11 .. 3*I10, I10+11 .. I10+I10); -- 11..30, 21..20 + SUBTYPE STR IS STRING; + ALF : CONSTANT STR(IDENT_INT(1)..IDENT_INT(5)) := "ABCDE"; + ARF : STR(5 .. 9) := ALF; + + PROCEDURE P1 (A : I_A; FIR, LAS: INTEGER; S : STRING) IS + BEGIN + IF A'FIRST /= FIR + OR A'FIRST(1) /= FIR + THEN + FAILED ("'FIRST IS WRONG " & S); + END IF; + + IF A'LAST /= LAS + OR A'LAST(1) /= LAS + THEN + FAILED ("'LAST IS WRONG " & S); + END IF; + + IF A'LENGTH /= LAS - FIR + 1 + OR A'LENGTH /= A'LENGTH(1) + THEN + FAILED ("'LENGTH IS WRONG " & S); + END IF; + + IF (LAS NOT IN A'RANGE AND LAS >= FIR) + OR (FIR NOT IN A'RANGE AND LAS >= FIR) + OR FIR - 1 IN A'RANGE + OR LAS + 1 IN A'RANGE(1) + THEN + FAILED ("'RANGE IS WRONG " & S); + END IF; + + END P1; + + PROCEDURE P2 (A : I_A_2; F1,L1,F2,L2 : INTEGER; S : STRING) IS + BEGIN + IF A'FIRST /= A'FIRST(1) + OR A'FIRST /= F1 + THEN + FAILED ("'FIRST(1) IS WRONG " & S); + END IF; + + IF A'LAST(1) /= L1 THEN + FAILED ("'LAST(1) IS WRONG " & S); + END IF; + + IF A'LENGTH(1) /= A'LENGTH + OR A'LENGTH /= L1 - F1 + 1 + THEN + FAILED ("'LENGTH(1) IS WRONG " & S); + END IF; + + IF F1 - 1 IN A'RANGE + OR (F1 NOT IN A'RANGE AND F1 <= L1) + OR (L1 NOT IN A'RANGE(1) AND F1 <= L1) + OR L1 + 1 IN A'RANGE(1) + THEN + FAILED ("'RANGE(1) IS WRONG " & S); + END IF; + + IF A'FIRST(2) /= F2 THEN + FAILED ("'FIRST(2) IS WRONG " & S); + END IF; + + IF A'LAST(2) /= L2 THEN + FAILED ("'LAST(2) IS WRONG " & S); + END IF; + + IF L2 - F2 /= A'LENGTH(2) - 1 THEN + FAILED ("'LENGTH(2) IS WRONG " & S); + END IF; + + IF F2 - 1 IN A'RANGE(2) + OR (F2 NOT IN A'RANGE(2) AND A'LENGTH(2) > 0) + OR (L2 NOT IN A'RANGE(2) AND A'LENGTH(2) /= 0) + OR L2 + 1 IN A'RANGE(2) + THEN + FAILED ("'RANGE(2) IS WRONG " & S); + END IF; + END P2; + + PROCEDURE S1 (S:STR; F,L:INTEGER; MESS:STRING) IS + BEGIN + IF S'FIRST /= F THEN + FAILED ("STRING 'FIRST IS WRONG " & MESS); + END IF; + + IF S'LAST(1) /= L THEN + FAILED ("STRING 'LAST IS WRONG " & MESS); + END IF; + + IF S'LENGTH /= L - F + 1 + OR S'LENGTH(1) /= S'LENGTH + THEN + FAILED ("STRING 'LENGTH IS WRONG " & MESS); + END IF; + + IF (F <= L AND + (F NOT IN S'RANGE + OR L NOT IN S'RANGE + OR F NOT IN S'RANGE(1) + OR L NOT IN S'RANGE(1))) + OR F - 1 IN S'RANGE + OR L + 1 IN S'RANGE(1) + THEN + FAILED ("STRING 'RANGE IS WRONG " & MESS); + END IF; + END S1; + +BEGIN + TEST ( "C36205I", "CHECKING ATTRIBUTE VALUES POSSESSED BY FORMAL "& + "PARAMETERS WHOSE ACTUALS ARE UNCONSTRAINED " & + "ARRAYS - DYNAMIC NULL AGGREGATES"); + + + P1 ((IDENT_INT(5) .. IDENT_INT(4) => 4), 5, 4, "P1 18"); + P1 ((IDENT_INT(1) .. IDENT_INT(0) => 0), 1, 0, "P1 19"); + P1 ((IDENT_INT(-12) .. -13 => 3), -12, -13, "P1 21"); + + RESULT; +END C36205I; diff --git a/gcc-4.9/gcc/testsuite/ada/acats/tests/c3/c36205j.ada b/gcc-4.9/gcc/testsuite/ada/acats/tests/c3/c36205j.ada new file mode 100644 index 000000000..a0d8218a6 --- /dev/null +++ b/gcc-4.9/gcc/testsuite/ada/acats/tests/c3/c36205j.ada @@ -0,0 +1,180 @@ +-- C36205J.ADA + +-- Grant of Unlimited Rights +-- +-- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687, +-- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained +-- unlimited rights in the software and documentation contained herein. +-- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making +-- this public release, the Government intends to confer upon all +-- recipients unlimited rights equal to those held by the Government. +-- These rights include rights to use, duplicate, release or disclose the +-- released technical data and computer software in whole or in part, in +-- any manner and for any purpose whatsoever, and to have or permit others +-- to do so. +-- +-- DISCLAIMER +-- +-- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR +-- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED +-- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF 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 ATTRIBUTES GIVE THE CORRECT VALUES FOR +-- UNCONSTRAINED FORMAL PARAMETERS. + +-- ATTRIBUTES OF SLICES AND AGGREGATES OF MORE COMPLEX FORMS + +-- DAT 2/17/81 +-- JBG 9/11/81 +-- JWC 6/28/85 RENAMED TO -AB + +WITH REPORT; +PROCEDURE C36205J IS + + USE REPORT; + + TYPE I_A IS ARRAY (INTEGER RANGE <> ) OF INTEGER; + TYPE I_A_2 IS ARRAY (INTEGER RANGE <> , + INTEGER RANGE <> ) OF INTEGER; + A10 : I_A (1 .. 10); + A20 : I_A (18 .. 20); + I10 : INTEGER := IDENT_INT (10); + A2_10 : I_A_2 (1 .. I10, 3+I10 .. I10+I10); -- 1..10, 13..20 + A2_20 : I_A_2 (11 .. 3*I10, I10+11 .. I10+I10); -- 11..30, 21..20 + TYPE STR IS NEW STRING; + ALF : CONSTANT STR := STR(IDENT_STR("ABCDE")); + ARF : STR(5 .. 9) := ALF; + + PROCEDURE P1 (A : I_A; FIR, LAS: INTEGER; S : STRING) IS + BEGIN + IF A'FIRST /= FIR + OR A'FIRST(1) /= FIR + THEN + FAILED ("'FIRST IS WRONG " & S); + END IF; + + IF A'LAST /= LAS + OR A'LAST(1) /= LAS + THEN + FAILED ("'LAST IS WRONG " & S); + END IF; + + IF A'LENGTH /= LAS - FIR + 1 + OR A'LENGTH /= A'LENGTH(1) + THEN + FAILED ("'LENGTH IS WRONG " & S); + END IF; + + IF (LAS NOT IN A'RANGE AND LAS >= FIR) + OR (FIR NOT IN A'RANGE AND LAS >= FIR) + OR FIR - 1 IN A'RANGE + OR LAS + 1 IN A'RANGE(1) + THEN + FAILED ("'RANGE IS WRONG " & S); + END IF; + + END P1; + + PROCEDURE P2 (A : I_A_2; F1,L1,F2,L2 : INTEGER; S : STRING) IS + BEGIN + IF A'FIRST /= A'FIRST(1) + OR A'FIRST /= F1 + THEN + FAILED ("'FIRST(1) IS WRONG " & S); + END IF; + + IF A'LAST(1) /= L1 THEN + FAILED ("'LAST(1) IS WRONG " & S); + END IF; + + IF A'LENGTH(1) /= A'LENGTH + OR A'LENGTH /= L1 - F1 + 1 + THEN + FAILED ("'LENGTH(1) IS WRONG " & S); + END IF; + + IF F1 - 1 IN A'RANGE + OR (F1 NOT IN A'RANGE AND F1 <= L1) + OR (L1 NOT IN A'RANGE(1) AND F1 <= L1) + OR L1 + 1 IN A'RANGE(1) + THEN + FAILED ("'RANGE(1) IS WRONG " & S); + END IF; + + IF A'FIRST(2) /= F2 THEN + FAILED ("'FIRST(2) IS WRONG " & S); + END IF; + + IF A'LAST(2) /= L2 THEN + FAILED ("'LAST(2) IS WRONG " & S); + END IF; + + IF L2 - F2 /= A'LENGTH(2) - 1 THEN + FAILED ("'LENGTH(2) IS WRONG " & S); + END IF; + + IF F2 - 1 IN A'RANGE(2) + OR (F2 NOT IN A'RANGE(2) AND A'LENGTH(2) > 0) + OR (L2 NOT IN A'RANGE(2) AND A'LENGTH(2) /= 0) + OR L2 + 1 IN A'RANGE(2) + THEN + FAILED ("'RANGE(2) IS WRONG " & S); + END IF; + END P2; + + PROCEDURE S1 (S:STR; F,L:INTEGER; MESS:STRING) IS + BEGIN + IF S'FIRST /= F THEN + FAILED ("STRING 'FIRST IS WRONG " & MESS); + END IF; + + IF S'LAST(1) /= L THEN + FAILED ("STRING 'LAST IS WRONG " & MESS); + END IF; + + IF S'LENGTH /= L - F + 1 + OR S'LENGTH(1) /= S'LENGTH + THEN + FAILED ("STRING 'LENGTH IS WRONG " & MESS); + END IF; + + IF (F <= L AND + (F NOT IN S'RANGE + OR L NOT IN S'RANGE + OR F NOT IN S'RANGE(1) + OR L NOT IN S'RANGE(1))) + OR F - 1 IN S'RANGE + OR L + 1 IN S'RANGE(1) + THEN + FAILED ("STRING 'RANGE IS WRONG " & MESS); + END IF; + END S1; + +BEGIN + TEST ( "C36205J", "CHECKING ATTRIBUTE VALUES POSSESSED BY FORMAL "& + "PARAMETERS WHOSE ACTUALS ARE UNCONSTRAINED " & + "ARRAYS - COMPLEX MIXTURE OF SLICES/AGGREGATES"); + + FOR J IN IDENT_INT (-3) .. IDENT_INT (3) LOOP + FOR K IN J - 1 .. 2 LOOP + P1 ((J .. K => 0), J, K, "X"); + P1 (A10 (J + 4 .. K + 4), J+4, K+4, "Y"); + END LOOP; + END LOOP; + FOR I IN 18 .. 20 LOOP + FOR J IN I-1 .. 20 LOOP + P1 (A20 (I .. J), I, J, "A20 88"); + END LOOP; + END LOOP; + FOR I IN 1 .. 5 LOOP + FOR J IN I - 1 .. 5 LOOP + S1( ALF (I .. J), I, J, "ALF 1"); + S1 (ARF (I+4..J+4), I+4, J+4, "ARF 4"); + END LOOP; + END LOOP; + + RESULT; +END C36205J; diff --git a/gcc-4.9/gcc/testsuite/ada/acats/tests/c3/c36205k.ada b/gcc-4.9/gcc/testsuite/ada/acats/tests/c3/c36205k.ada new file mode 100644 index 000000000..44a80767f --- /dev/null +++ b/gcc-4.9/gcc/testsuite/ada/acats/tests/c3/c36205k.ada @@ -0,0 +1,173 @@ +-- C36205K.ADA + +-- Grant of Unlimited Rights +-- +-- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687, +-- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained +-- unlimited rights in the software and documentation contained herein. +-- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making +-- this public release, the Government intends to confer upon all +-- recipients unlimited rights equal to those held by the Government. +-- These rights include rights to use, duplicate, release or disclose the +-- released technical data and computer software in whole or in part, in +-- any manner and for any purpose whatsoever, and to have or permit others +-- to do so. +-- +-- DISCLAIMER +-- +-- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR +-- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED +-- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF 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 ATTRIBUTES GIVE THE CORRECT VALUES FOR +-- UNCONSTRAINED FORMAL PARAMETERS. + +-- ATTRIBUTES OF SLICE OF SLICE + +-- DAT 2/17/81 +-- JBG 9/11/81 +-- JWC 6/28/85 RENAMED TO -AB + +WITH REPORT; +PROCEDURE C36205K IS + + USE REPORT; + + TYPE I_A IS ARRAY (INTEGER RANGE <> ) OF INTEGER; + TYPE I_A_2 IS ARRAY (INTEGER RANGE <> , + INTEGER RANGE <> ) OF INTEGER; + A10 : I_A (1 .. 10); + A20 : I_A (18 .. 20); + I10 : INTEGER := IDENT_INT (10); + A2_10 : I_A_2 (1 .. I10, 3+I10 .. I10+I10); -- 1..10, 13..20 + A2_20 : I_A_2 (11 .. 3*I10, I10+11 .. I10+I10); -- 11..30, 21..20 + TYPE STR IS NEW STRING; + ALF : CONSTANT STR := STR(IDENT_STR("ABCDE")); + ARF : STR(5 .. 9) := ALF; + + PROCEDURE P1 (A : I_A; FIR, LAS: INTEGER; S : STRING) IS + BEGIN + IF A'FIRST /= FIR + OR A'FIRST(1) /= FIR + THEN + FAILED ("'FIRST IS WRONG " & S); + END IF; + + IF A'LAST /= LAS + OR A'LAST(1) /= LAS + THEN + FAILED ("'LAST IS WRONG " & S); + END IF; + + IF A'LENGTH /= LAS - FIR + 1 + OR A'LENGTH /= A'LENGTH(1) + THEN + FAILED ("'LENGTH IS WRONG " & S); + END IF; + + IF (LAS NOT IN A'RANGE AND LAS >= FIR) + OR (FIR NOT IN A'RANGE AND LAS >= FIR) + OR FIR - 1 IN A'RANGE + OR LAS + 1 IN A'RANGE(1) + THEN + FAILED ("'RANGE IS WRONG " & S); + END IF; + + END P1; + + PROCEDURE P2 (A : I_A_2; F1,L1,F2,L2 : INTEGER; S : STRING) IS + BEGIN + IF A'FIRST /= A'FIRST(1) + OR A'FIRST /= F1 + THEN + FAILED ("'FIRST(1) IS WRONG " & S); + END IF; + + IF A'LAST(1) /= L1 THEN + FAILED ("'LAST(1) IS WRONG " & S); + END IF; + + IF A'LENGTH(1) /= A'LENGTH + OR A'LENGTH /= L1 - F1 + 1 + THEN + FAILED ("'LENGTH(1) IS WRONG " & S); + END IF; + + IF F1 - 1 IN A'RANGE + OR (F1 NOT IN A'RANGE AND F1 <= L1) + OR (L1 NOT IN A'RANGE(1) AND F1 <= L1) + OR L1 + 1 IN A'RANGE(1) + THEN + FAILED ("'RANGE(1) IS WRONG " & S); + END IF; + + IF A'FIRST(2) /= F2 THEN + FAILED ("'FIRST(2) IS WRONG " & S); + END IF; + + IF A'LAST(2) /= L2 THEN + FAILED ("'LAST(2) IS WRONG " & S); + END IF; + + IF L2 - F2 /= A'LENGTH(2) - 1 THEN + FAILED ("'LENGTH(2) IS WRONG " & S); + END IF; + + IF F2 - 1 IN A'RANGE(2) + OR (F2 NOT IN A'RANGE(2) AND A'LENGTH(2) > 0) + OR (L2 NOT IN A'RANGE(2) AND A'LENGTH(2) /= 0) + OR L2 + 1 IN A'RANGE(2) + THEN + FAILED ("'RANGE(2) IS WRONG " & S); + END IF; + END P2; + + PROCEDURE S1 (S:STR; F,L:INTEGER; MESS:STRING) IS + BEGIN + IF S'FIRST /= F THEN + FAILED ("STRING 'FIRST IS WRONG " & MESS); + END IF; + + IF S'LAST(1) /= L THEN + FAILED ("STRING 'LAST IS WRONG " & MESS); + END IF; + + IF S'LENGTH /= L - F + 1 + OR S'LENGTH(1) /= S'LENGTH + THEN + FAILED ("STRING 'LENGTH IS WRONG " & MESS); + END IF; + + IF (F <= L AND + (F NOT IN S'RANGE + OR L NOT IN S'RANGE + OR F NOT IN S'RANGE(1) + OR L NOT IN S'RANGE(1))) + OR F - 1 IN S'RANGE + OR L + 1 IN S'RANGE(1) + THEN + FAILED ("STRING 'RANGE IS WRONG " & MESS); + END IF; + END S1; + +BEGIN + TEST ( "C36205K", "CHECKING ATTRIBUTE VALUES POSSESSED BY FORMAL "& + "PARAMETERS WHOSE ACTUALS ARE UNCONSTRAINED " & + "ARRAYS - SLICES OF SLICES"); + + FOR I IN 18 .. 20 LOOP + FOR J IN I-1 .. 20 LOOP + P1 (A20 (A20'RANGE)(I..J), I, J, "A20 99"); + END LOOP; + END LOOP; + FOR I IN 1 .. 5 LOOP + FOR J IN I - 1 .. 5 LOOP + S1 (ALF (1..5)(I..J),I,J,"ALF 3"); + END LOOP; + END LOOP; + + RESULT; +END C36205K; diff --git a/gcc-4.9/gcc/testsuite/ada/acats/tests/c3/c36205l.ada b/gcc-4.9/gcc/testsuite/ada/acats/tests/c3/c36205l.ada new file mode 100644 index 000000000..9a1126e34 --- /dev/null +++ b/gcc-4.9/gcc/testsuite/ada/acats/tests/c3/c36205l.ada @@ -0,0 +1,288 @@ +-- C36205L.ADA + +-- Grant of Unlimited Rights +-- +-- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687, +-- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained +-- unlimited rights in the software and documentation contained herein. +-- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making +-- this public release, the Government intends to confer upon all +-- recipients unlimited rights equal to those held by the Government. +-- These rights include rights to use, duplicate, release or disclose the +-- released technical data and computer software in whole or in part, in +-- any manner and for any purpose whatsoever, and to have or permit others +-- to do so. +-- +-- DISCLAIMER +-- +-- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR +-- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED +-- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE +-- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE +-- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A +-- PARTICULAR PURPOSE OF SAID MATERIAL. +--* +-- OBJECTIVE +-- FOR GENERIC PROCEDURES, CHECK THAT ATTRIBUTES GIVE THE +-- CORRECT VALUES FOR UNCONSTRAINED FORMAL PARAMETERS. +-- BASIC CHECKS OF ARRAY OBJECTS AND WHOLE ARRAYS PASSED AS +-- PARAMETERS TO GENERIC PROCEDURES + +-- HISTORY +-- EDWARD V. BERARD, 9 AUGUST 1990 +-- DAS 8 OCT 1990 ADDED OUT MODE PARAMETER TO GENERIC +-- PROCEDURE TEST_PROCEDURE AND FORMAL +-- GENERIC PARAMETER COMPONENT_VALUE. + +WITH REPORT ; + +PROCEDURE C36205L IS + + SHORT_START : CONSTANT := -100 ; + SHORT_END : CONSTANT := 100 ; + TYPE SHORT_RANGE IS RANGE SHORT_START .. SHORT_END ; + SHORT_LENGTH : CONSTANT NATURAL := (SHORT_END - SHORT_START + 1) ; + + MEDIUM_START : CONSTANT := 1 ; + MEDIUM_END : CONSTANT := 100 ; + TYPE MEDIUM_RANGE IS RANGE MEDIUM_START .. MEDIUM_END ; + MEDIUM_LENGTH : CONSTANT NATURAL := (MEDIUM_END - MEDIUM_START + + 1) ; + + TYPE MONTH_TYPE IS (JAN, FEB, MAR, APR, MAY, JUN, JUL, AUG, + SEP, OCT, NOV, DEC) ; + TYPE DAY_TYPE IS RANGE 1 .. 31 ; + TYPE YEAR_TYPE IS RANGE 1904 .. 2050 ; + TYPE DATE IS RECORD + MONTH : MONTH_TYPE ; + DAY : DAY_TYPE ; + YEAR : YEAR_TYPE ; + END RECORD ; + + TODAY : DATE := (MONTH => AUG, + DAY => 9, + YEAR => 1990) ; + + SUBTYPE SHORT_STRING IS STRING (1 ..5) ; + + DEFAULT_STRING : SHORT_STRING := "ABCDE" ; + + TYPE FIRST_TEMPLATE IS ARRAY (SHORT_RANGE RANGE <>, + MEDIUM_RANGE RANGE <>) OF DATE ; + + TYPE SECOND_TEMPLATE IS ARRAY (MONTH_TYPE RANGE <>, + DAY_TYPE RANGE <>) OF SHORT_STRING ; + + TYPE THIRD_TEMPLATE IS ARRAY (CHARACTER RANGE <>, + BOOLEAN RANGE <>) OF DAY_TYPE ; + + FIRST_ARRAY : FIRST_TEMPLATE (-10 .. 10, 27 .. 35) + := (-10 .. 10 => + (27 .. 35 => TODAY)) ; + SECOND_ARRAY : SECOND_TEMPLATE (JAN .. JUN, 1 .. 25) + := (JAN .. JUN => + (1 .. 25 => DEFAULT_STRING)) ; + THIRD_ARRAY : THIRD_TEMPLATE ('A' .. 'Z', FALSE .. TRUE) + := ('A' .. 'Z' => + (FALSE .. TRUE => DAY_TYPE (9))) ; + + FOURTH_ARRAY : FIRST_TEMPLATE (0 .. 27, 75 .. 100) + := (0 .. 27 => + (75 .. 100 => TODAY)) ; + FIFTH_ARRAY : SECOND_TEMPLATE (JUL .. OCT, 6 .. 10) + := (JUL .. OCT => + (6 .. 10 => DEFAULT_STRING)) ; + SIXTH_ARRAY : THIRD_TEMPLATE ('X' .. 'Z', TRUE .. TRUE) + := ('X' .. 'Z' => + (TRUE .. TRUE => DAY_TYPE (31))) ; + + GENERIC + + TYPE FIRST_INDEX IS (<>) ; + TYPE SECOND_INDEX IS (<>) ; + TYPE COMPONENT_TYPE IS PRIVATE ; + TYPE UNCONSTRAINED_ARRAY IS ARRAY (FIRST_INDEX RANGE <>, + SECOND_INDEX RANGE <>) OF COMPONENT_TYPE ; + COMPONENT_VALUE: IN COMPONENT_TYPE; + + PROCEDURE TEST_PROCEDURE (FIRST : IN UNCONSTRAINED_ARRAY ; + FFIFS : IN FIRST_INDEX ; + FFILS : IN FIRST_INDEX ; + FSIFS : IN SECOND_INDEX ; + FSILS : IN SECOND_INDEX ; + FFLEN : IN NATURAL ; + FSLEN : IN NATURAL ; + FFIRT : IN FIRST_INDEX ; + FSIRT : IN SECOND_INDEX ; + SECOND : OUT UNCONSTRAINED_ARRAY ; + SFIFS : IN FIRST_INDEX ; + SFILS : IN FIRST_INDEX ; + SSIFS : IN SECOND_INDEX ; + SSILS : IN SECOND_INDEX ; + SFLEN : IN NATURAL ; + SSLEN : IN NATURAL ; + SFIRT : IN FIRST_INDEX ; + SSIRT : IN SECOND_INDEX ; + REMARKS : IN STRING) ; + + PROCEDURE TEST_PROCEDURE (FIRST : IN UNCONSTRAINED_ARRAY ; + FFIFS : IN FIRST_INDEX ; + FFILS : IN FIRST_INDEX ; + FSIFS : IN SECOND_INDEX ; + FSILS : IN SECOND_INDEX ; + FFLEN : IN NATURAL ; + FSLEN : IN NATURAL ; + FFIRT : IN FIRST_INDEX ; + FSIRT : IN SECOND_INDEX ; + SECOND : OUT UNCONSTRAINED_ARRAY ; + SFIFS : IN FIRST_INDEX ; + SFILS : IN FIRST_INDEX ; + SSIFS : IN SECOND_INDEX ; + SSILS : IN SECOND_INDEX ; + SFLEN : IN NATURAL ; + SSLEN : IN NATURAL ; + SFIRT : IN FIRST_INDEX ; + SSIRT : IN SECOND_INDEX ; + REMARKS : IN STRING) IS + + BEGIN -- TEST_PROCEDURE + + IF (FIRST'FIRST /= FFIFS) OR + (FIRST'FIRST (1) /= FFIFS) OR + (FIRST'FIRST (2) /= FSIFS) OR + (SECOND'FIRST /= SFIFS) OR + (SECOND'FIRST (1) /= SFIFS) OR + (SECOND'FIRST (2) /= SSIFS) THEN + REPORT.FAILED ("PROBLEMS WITH 'FIRST. " & REMARKS) ; + END IF ; + + IF (FIRST'LAST /= FFILS) OR + (FIRST'LAST (1) /= FFILS) OR + (FIRST'LAST (2) /= FSILS) OR + (SECOND'LAST /= SFILS) OR + (SECOND'LAST (1) /= SFILS) OR + (SECOND'LAST (2) /= SSILS) THEN + REPORT.FAILED ("PROBLEMS WITH 'LAST. " & REMARKS) ; + END IF ; + + IF (FIRST'LENGTH /= FFLEN) OR + (FIRST'LENGTH (1) /= FFLEN) OR + (FIRST'LENGTH (2) /= FSLEN) OR + (SECOND'LENGTH /= SFLEN) OR + (SECOND'LENGTH (1) /= SFLEN) OR + (SECOND'LENGTH (2) /= SSLEN) THEN + REPORT.FAILED ("PROBLEMS WITH 'LENGTH. " & REMARKS) ; + END IF ; + + IF (FFIRT NOT IN FIRST'RANGE (1)) OR + (FFIRT NOT IN FIRST'RANGE) OR + (SFIRT NOT IN SECOND'RANGE (1)) OR + (SFIRT NOT IN SECOND'RANGE) OR + (FSIRT NOT IN FIRST'RANGE (2)) OR + (SSIRT NOT IN SECOND'RANGE (2)) THEN + REPORT.FAILED ("INCORRECT HANDLING OF 'RANGE " & + "ATTRIBUTE. " & REMARKS) ; + END IF ; + + -- ASSIGN VALUES TO THE ARRAY PARAMETER OF MODE OUT + FOR I IN SECOND'RANGE(1) LOOP + FOR J IN SECOND'RANGE(2) LOOP + SECOND(I, J) := COMPONENT_VALUE; + END LOOP; + END LOOP; + + END TEST_PROCEDURE ; + + PROCEDURE FIRST_TEST_PROCEDURE IS NEW TEST_PROCEDURE ( + FIRST_INDEX => SHORT_RANGE, + SECOND_INDEX => MEDIUM_RANGE, + COMPONENT_TYPE => DATE, + UNCONSTRAINED_ARRAY => FIRST_TEMPLATE, + COMPONENT_VALUE => TODAY) ; + + PROCEDURE SECOND_TEST_PROCEDURE IS NEW TEST_PROCEDURE ( + FIRST_INDEX => MONTH_TYPE, + SECOND_INDEX => DAY_TYPE, + COMPONENT_TYPE => SHORT_STRING, + UNCONSTRAINED_ARRAY => SECOND_TEMPLATE, + COMPONENT_VALUE => DEFAULT_STRING) ; + + PROCEDURE THIRD_TEST_PROCEDURE IS NEW TEST_PROCEDURE ( + FIRST_INDEX => CHARACTER, + SECOND_INDEX => BOOLEAN, + COMPONENT_TYPE => DAY_TYPE, + UNCONSTRAINED_ARRAY => THIRD_TEMPLATE, + COMPONENT_VALUE => DAY_TYPE'FIRST) ; + + +BEGIN -- C36205L + + REPORT.TEST ( "C36205L","FOR GENERIC PROCEDURES, CHECK THAT " & + "ATTRIBUTES GIVE THE CORRECT VALUES FOR " & + "UNCONSTRAINED FORMAL PARAMETERS. BASIC " & + "CHECKS OF ARRAY OBJECTS AND WHOLE ARRAYS " & + "PASSED AS PARAMETERS TO GENERIC PROCEDURES"); + + FIRST_TEST_PROCEDURE (FIRST => FIRST_ARRAY, + FFIFS => -10, + FFILS => 10, + FSIFS => 27, + FSILS => 35, + FFLEN => 21, + FSLEN => 9, + FFIRT => 0, + FSIRT => 29, + SECOND => FOURTH_ARRAY, + SFIFS => 0, + SFILS => 27, + SSIFS => 75, + SSILS => 100, + SFLEN => 28, + SSLEN => 26, + SFIRT => 5, + SSIRT => 100, + REMARKS => "FIRST_TEST_PROCEDURE") ; + + SECOND_TEST_PROCEDURE (FIRST => SECOND_ARRAY, + FFIFS => JAN, + FFILS => JUN, + FSIFS => 1, + FSILS => 25, + FFLEN => 6, + FSLEN => 25, + FFIRT => MAR, + FSIRT => 17, + SECOND => FIFTH_ARRAY, + SFIFS => JUL, + SFILS => OCT, + SSIFS => 6, + SSILS => 10, + SFLEN => 4, + SSLEN => 5, + SFIRT => JUL, + SSIRT => 6, + REMARKS => "SECOND_TEST_PROCEDURE") ; + + THIRD_TEST_PROCEDURE (FIRST => THIRD_ARRAY, + FFIFS => 'A', + FFILS => 'Z', + FSIFS => FALSE, + FSILS => TRUE, + FFLEN => 26, + FSLEN => 2, + FFIRT => 'T', + FSIRT => TRUE, + SECOND => SIXTH_ARRAY, + SFIFS => 'X', + SFILS => 'Z', + SSIFS => TRUE, + SSILS => TRUE, + SFLEN => 3, + SSLEN => 1, + SFIRT => 'Z', + SSIRT => TRUE, + REMARKS => "THIRD_TEST_PROCEDURE") ; + + REPORT.RESULT ; + +END C36205L ; diff --git a/gcc-4.9/gcc/testsuite/ada/acats/tests/c3/c36301a.ada b/gcc-4.9/gcc/testsuite/ada/acats/tests/c3/c36301a.ada new file mode 100644 index 000000000..9f93a7f3b --- /dev/null +++ b/gcc-4.9/gcc/testsuite/ada/acats/tests/c3/c36301a.ada @@ -0,0 +1,149 @@ +-- C36301A.ADA + +-- Grant of Unlimited Rights +-- +-- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687, +-- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained +-- unlimited rights in the software and documentation contained herein. +-- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making +-- this public release, the Government intends to confer upon all +-- recipients unlimited rights equal to those held by the Government. +-- These rights include rights to use, duplicate, release or disclose the +-- released technical data and computer software in whole or in part, in +-- any manner and for any purpose whatsoever, and to have or permit others +-- to do so. +-- +-- DISCLAIMER +-- +-- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR +-- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED +-- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE +-- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE +-- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A +-- PARTICULAR PURPOSE OF SAID MATERIAL. +--* +-- CHECK THAT PREDEFINED POSITIVE AND STRING TYPES +-- ARE CORRECTLY DEFINED. + +-- DAT 2/17/81 +-- JBG 12/27/82 +-- RJW 1/20/86 - CHANGED 'NATURAL' TO 'POSITIVE'. ADDED ADDITIONAL +-- CASES, INCLUDING A CHECK FOR STRINGS WITH BOUNDS +-- OF INTEGER'FIRST AND INTEGER'LAST. +-- EDS 7/16/98 AVOID OPTIMIZATION + +WITH REPORT; USE REPORT; + +PROCEDURE C36301A IS + +BEGIN + TEST ( "C36301A", "CHECK ATTRIBUTES OF PREDEFINED POSITIVE " & + "AND STRING" ); + + BEGIN + IF POSITIVE'FIRST /= 1 THEN + FAILED ( "POSITIVE'FIRST IS WRONG" ); + END IF; + + IF POSITIVE'LAST /= INTEGER'LAST THEN + FAILED ( "POSITIVE'LAST IS WRONG" ); + END IF; + END; + + DECLARE + + C : STRING (1..2) := ( 'A', 'B' ); + + BEGIN + IF C'LENGTH /= 2 THEN + FAILED ( "LENGTH OF C IS WRONG" ); + END IF; + + IF C'FIRST /= 1 THEN + FAILED ( "C'FIRST IS WRONG" ); + END IF; + + IF C'LAST /= 2 THEN + FAILED ( "C'LAST IS WRONG" ); + END IF; + END; + + DECLARE + + SUBTYPE LARGE IS STRING ( INTEGER'LAST - 3 .. INTEGER'LAST ); + + BEGIN + IF LARGE'LENGTH /= 4 THEN + FAILED ( "LENGTH OF LARGE IS WRONG" ); + END IF; + + IF LARGE'FIRST /= INTEGER'LAST - 3 THEN + FAILED ( "LARGE'FIRST IS WRONG" ); + END IF; + + IF LARGE'LAST /= INTEGER'LAST THEN + FAILED ( "LARGE'LAST IS WRONG" ); + END IF; + END; + + DECLARE + + SUBTYPE LARGER IS STRING ( 1 .. INTEGER'LAST ); + + BEGIN + IF LARGER'LENGTH /= INTEGER'LAST THEN + FAILED ( "LENGTH OF LARGER IS WRONG" ); + END IF; + + IF LARGER'FIRST /= 1 THEN + FAILED ( "LARGER'FIRST IS WRONG" ); + END IF; + + IF LARGER'LAST /= INTEGER'LAST THEN + FAILED ( "LARGER'LAST IS WRONG" ); + END IF; + END; + + BEGIN + DECLARE + + D : STRING ( INTEGER'FIRST .. INTEGER'FIRST + 3 ); + + BEGIN + IF D'FIRST /= INTEGER'FIRST THEN -- USE D + FAILED ("D'FIRST IS INCORRECT " & INTEGER'IMAGE(D'FIRST)); + END IF; + FAILED ( "NO EXCEPTION RAISED" ); + END; + EXCEPTION + WHEN CONSTRAINT_ERROR => + NULL; + WHEN OTHERS => + FAILED ( "WRONG EXCEPTION RAISED" ); + END; + + BEGIN + DECLARE + + E : STRING ( -1 .. INTEGER'FIRST ); + + BEGIN + IF E'LENGTH /= 0 THEN + FAILED ( "LENGTH OF E IS WRONG" ); + END IF; + + IF E'FIRST /= -1 THEN + FAILED ( "E'FIRST IS WRONG" ); + END IF; + + IF E'LAST /= INTEGER'FIRST THEN + FAILED ( "E'LAST IS WRONG" ); + END IF; + END; + EXCEPTION + WHEN OTHERS => + FAILED ( "EXCEPTION RAISED FOR NULL STRING" ); + END; + + RESULT; +END C36301A; diff --git a/gcc-4.9/gcc/testsuite/ada/acats/tests/c3/c36301b.ada b/gcc-4.9/gcc/testsuite/ada/acats/tests/c3/c36301b.ada new file mode 100644 index 000000000..4153db2a5 --- /dev/null +++ b/gcc-4.9/gcc/testsuite/ada/acats/tests/c3/c36301b.ada @@ -0,0 +1,55 @@ +-- C36301B.ADA + +-- Grant of Unlimited Rights +-- +-- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687, +-- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained +-- unlimited rights in the software and documentation contained herein. +-- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making +-- this public release, the Government intends to confer upon all +-- recipients unlimited rights equal to those held by the Government. +-- These rights include rights to use, duplicate, release or disclose the +-- released technical data and computer software in whole or in part, in +-- any manner and for any purpose whatsoever, and to have or permit others +-- to do so. +-- +-- DISCLAIMER +-- +-- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR +-- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED +-- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE +-- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE +-- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A +-- PARTICULAR PURPOSE OF SAID MATERIAL. +--* +-- CHECK THAT PREDEFINED STRING ATTRIBUTES ARE CORRECTLY IMPLEMENTED. + +-- CASE B: STRING OF LENGTH INTEGER'LAST + +-- DAT 2/17/81 +-- JBG 12/28/82 + +WITH REPORT; +PROCEDURE C36301B IS + + USE REPORT; + + SUBTYPE STR2 IS STRING (1..INTEGER'LAST); + +BEGIN + TEST("C36301B", "CHECK ATTRIBUTES OF LONGEST STRING"); + + IF STR2'FIRST /= 1 THEN + FAILED ("STR'FIRST NOT 1"); + END IF; + + IF STR2'LAST /= INTEGER'LAST THEN + FAILED ("STR'LAST NOT INTEGER'LAST"); + END IF; + + IF STR2'LENGTH /= INTEGER'LAST THEN + FAILED ("'LENGTH NOT INTEGER'LAST"); + END IF; + + RESULT; +END C36301B; diff --git a/gcc-4.9/gcc/testsuite/ada/acats/tests/c3/c36302a.ada b/gcc-4.9/gcc/testsuite/ada/acats/tests/c3/c36302a.ada new file mode 100644 index 000000000..1e7159879 --- /dev/null +++ b/gcc-4.9/gcc/testsuite/ada/acats/tests/c3/c36302a.ada @@ -0,0 +1,53 @@ +-- C36302A.ADA + +-- Grant of Unlimited Rights +-- +-- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687, +-- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained +-- unlimited rights in the software and documentation contained herein. +-- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making +-- this public release, the Government intends to confer upon all +-- recipients unlimited rights equal to those held by the Government. +-- These rights include rights to use, duplicate, release or disclose the +-- released technical data and computer software in whole or in part, in +-- any manner and for any purpose whatsoever, and to have or permit others +-- to do so. +-- +-- DISCLAIMER +-- +-- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR +-- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED +-- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF 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 STRING VARIABLE MAY BE DECLARED WITH AN INDEX +-- STARTING WITH AN INTEGER GREATER THAN 1. + +-- DAT 2/17/81 +-- JWC 6/28/85 RENAMED TO -AB + +WITH REPORT; +PROCEDURE C36302A IS + + USE REPORT; + + S5 : STRING (5 .. 10); + SX : STRING (INTEGER'LAST - 5 .. INTEGER'LAST); + +BEGIN + TEST ("C36302A", "STRING VARIABLE INDICES NEEDN'T START AT 1"); + + IF S5'FIRST /= 5 + OR S5'LAST /= 10 + OR S5'LENGTH /= 6 + OR SX'FIRST /= INTEGER'LAST - 5 + OR SX'LAST /= INTEGER'LAST + OR SX'LENGTH /= 6 + THEN + FAILED ("WRONG STRING ATTRIBUTES"); + END IF; + + RESULT; +END C36302A; diff --git a/gcc-4.9/gcc/testsuite/ada/acats/tests/c3/c36304a.ada b/gcc-4.9/gcc/testsuite/ada/acats/tests/c3/c36304a.ada new file mode 100644 index 000000000..a561f3fdd --- /dev/null +++ b/gcc-4.9/gcc/testsuite/ada/acats/tests/c3/c36304a.ada @@ -0,0 +1,91 @@ +-- C36304A.ADA + +-- Grant of Unlimited Rights +-- +-- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687, +-- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained +-- unlimited rights in the software and documentation contained herein. +-- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making +-- this public release, the Government intends to confer upon all +-- recipients unlimited rights equal to those held by the Government. +-- These rights include rights to use, duplicate, release or disclose the +-- released technical data and computer software in whole or in part, in +-- any manner and for any purpose whatsoever, and to have or permit others +-- to do so. +-- +-- DISCLAIMER +-- +-- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR +-- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED +-- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF 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 BOUNDS OF CONSTANT STRING OBJECTS IF NOT GIVEN IN +-- THE DECLARATIONS ARE DETERMINED BY THE STRINGS' INITIAL VALUES. + +-- DAT 2/17/81 +-- JBG 8/21/83 + +WITH REPORT; +PROCEDURE C36304A IS + + USE REPORT; + + I3 : INTEGER := IDENT_INT (3); + + S3 : CONSTANT STRING := "ABC"; + S0 : CONSTANT STRING := ""; + S1 : CONSTANT STRING := "A"; + S2 : CONSTANT STRING := "AB"; + S5 : CONSTANT STRING := "ABCDE"; + S3A : CONSTANT STRING (I3 .. I3 + 2) := S3(I3 - 2 .. I3); + S3C : CONSTANT STRING := S3A; + S3D : CONSTANT STRING := S3C & ""; + S3E : CONSTANT STRING := S3D; + X3 : CONSTANT STRING := (I3 .. 5 => 'X'); + Y3 : CONSTANT STRING := X3; + Z0 : CONSTANT STRING := (-3..-5 => 'A'); + + PROCEDURE C (S : STRING; + FIRST, LAST, LENGTH : INTEGER; + ID : STRING) IS + BEGIN + IF S'FIRST /= FIRST THEN + FAILED ("'FIRST IS " & INTEGER'IMAGE(S'FIRST) & + " INSTEAD OF " & INTEGER'IMAGE(FIRST) & + " FOR " & ID); + END IF; + + IF S'LAST /= LAST THEN + FAILED ("'LAST IS " & INTEGER'IMAGE(S'LAST) & + " INSTEAD OF " & INTEGER'IMAGE(LAST) & + " FOR " & ID); + END IF; + + IF S'LENGTH /= LENGTH THEN + FAILED ("'LENGTH IS " & INTEGER'IMAGE(S'LENGTH) & + " INSTEAD OF " & INTEGER'IMAGE(LENGTH) & + " FOR " & ID); + END IF; + END C; + +BEGIN + TEST ("C36304A", "CHECK UNUSUAL CONSTANT STRING BOUNDS"); + + + C(S0, 1, 0, 0, "S0"); + C(S1, 1, 1, 1, "S1"); + C(S2, 1, 2, 2, "S2"); + C(S5, 1, 5, 5, "S5"); + C(S3, 1, 3, 3, "S3"); + C(S3C, 3, 5, 3, "S3C"); + C(S3D, 3, 5, 3, "S3D"); + C(S3E, 3, 5, 3, "S3E"); + C(X3, 3, 5, 3, "X3"); + C(Y3, 3, 5, 3, "Y3"); + C(Z0, IDENT_INT(-3), IDENT_INT(-5), IDENT_INT(0), "Z0"); + + RESULT; +END C36304A; diff --git a/gcc-4.9/gcc/testsuite/ada/acats/tests/c3/c36305a.ada b/gcc-4.9/gcc/testsuite/ada/acats/tests/c3/c36305a.ada new file mode 100644 index 000000000..09adbe156 --- /dev/null +++ b/gcc-4.9/gcc/testsuite/ada/acats/tests/c3/c36305a.ada @@ -0,0 +1,117 @@ +-- C36305A.ADA + +-- Grant of Unlimited Rights +-- +-- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687, +-- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained +-- unlimited rights in the software and documentation contained herein. +-- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making +-- this public release, the Government intends to confer upon all +-- recipients unlimited rights equal to those held by the Government. +-- These rights include rights to use, duplicate, release or disclose the +-- released technical data and computer software in whole or in part, in +-- any manner and for any purpose whatsoever, and to have or permit others +-- to do so. +-- +-- DISCLAIMER +-- +-- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR +-- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED +-- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF 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 STRING VARIABLE IS CONSIDERED AN ARRAY. + +-- DAT 2/17/81 +-- SPS 10/25/82 +-- EDS 07/16/98 AVOID OPTIMIZATION + +WITH REPORT; +PROCEDURE C36305A IS + + USE REPORT; + + S : STRING (IDENT_INT(5) .. IDENT_INT (10)); + T : STRING (S'RANGE); + U : STRING (T'FIRST .. T'LAST); + SUBTYPE I_5 IS INTEGER RANGE U'RANGE(1); + I5 : I_5; + C : CONSTANT STRING := "ABCDEF"; + +BEGIN + TEST ("C36305A", "CHECK THAT STRINGS ARE REALLY ARRAYS"); + + IF S'FIRST /= 5 + OR S'LAST /= 10 + OR S'LENGTH /= 6 + OR U'FIRST(1) /= 5 + OR U'LAST(1) /= 10 + OR U'LENGTH(1) /= 6 + THEN + FAILED ("INCORRECT STRING ATTRIBUTE VALUES"); + END IF; + + IF 4 IN U'RANGE + OR 3 IN U'RANGE(1) + OR 0 IN U'RANGE + OR 1 IN U'RANGE + OR 5 NOT IN U'RANGE + OR 7 NOT IN U'RANGE + OR 10 NOT IN U'RANGE + OR NOT (11 NOT IN U'RANGE) + THEN + FAILED ("INCORRECT STRING RANGE ATTRIBUTE"); + END IF; + + BEGIN + BEGIN + BEGIN + I5 := 4; + FAILED ("BAD I5 SUBRANGE 1 " & INTEGER'IMAGE(I5)); --use I5 + EXCEPTION + WHEN CONSTRAINT_ERROR => NULL; + END; + I5 := INTEGER'(11); + FAILED ("BAD I5 SUBRANGE 2 " & INTEGER'IMAGE(I5)); --use I5 + EXCEPTION + WHEN CONSTRAINT_ERROR => NULL; + WHEN OTHERS => FAILED ("WRONG EXCEPTION RAISED 1"); + END; + I5 := INTEGER'(5); + I5 := I5 + I5; + I5 := NATURAL'(8); + EXCEPTION + WHEN OTHERS => FAILED ("WRONG EXCEPTION RAISED 2"); + END; + + FOR I IN S'RANGE LOOP + S(I) := C(11 - I); + END LOOP; + T := S; + FOR I IN REVERSE U'RANGE LOOP + U(I) := T(15 - I); + END LOOP; + + FOR I IN 1 .. C'LENGTH LOOP + IF C(1 .. I) /= U(5 .. I + 4) + OR U(I + 4 .. U'LAST) /= C(I .. C'LAST) + OR C(I) /= U (I + 4) + OR C(I .. I)(I .. I)(I) /= U(U'RANGE)(I + 4) THEN + FAILED ("INCORRECT CHARACTER MISMATCH IN STRING"); + EXIT; + END IF; + END LOOP; + + IF U /= C + OR U /= "ABCDEF" + OR U(U'RANGE) /= C(C'RANGE) + OR U(5 .. 10) /= C(1 .. 6) + OR U(5 .. 6) /= C(1 .. 2) + THEN + FAILED ("STRINGS AS ARRAYS BEHAVE INCORRECTLY"); + END IF; + + RESULT; +END C36305A; diff --git a/gcc-4.9/gcc/testsuite/ada/acats/tests/c3/c37002a.ada b/gcc-4.9/gcc/testsuite/ada/acats/tests/c3/c37002a.ada new file mode 100644 index 000000000..fbb61cf39 --- /dev/null +++ b/gcc-4.9/gcc/testsuite/ada/acats/tests/c3/c37002a.ada @@ -0,0 +1,79 @@ +-- C37002A.ADA + +-- Grant of Unlimited Rights +-- +-- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687, +-- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained +-- unlimited rights in the software and documentation contained herein. +-- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making +-- this public release, the Government intends to confer upon all +-- recipients unlimited rights equal to those held by the Government. +-- These rights include rights to use, duplicate, release or disclose the +-- released technical data and computer software in whole or in part, in +-- any manner and for any purpose whatsoever, and to have or permit others +-- to do so. +-- +-- DISCLAIMER +-- +-- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR +-- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED +-- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF 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 INDEX CONSTRAINTS WITH NON-STATIC EXPRESSIONS CAN BE +-- USED TO CONSTRAIN RECORD COMPONENTS HAVING AN ARRAY TYPE. + +-- RJW 2/28/86 + +WITH REPORT; USE REPORT; + +PROCEDURE C37002A IS + +BEGIN + TEST ( "C37002A", "CHECK THAT INDEX CONSTRAINTS WITH " & + "NON-STATIC EXPRESSIONS CAN BE USED TO " & + "CONSTRAIN RECORD COMPONENTS HAVING AN " & + "ARRAY TYPE" ); + + DECLARE + X : INTEGER := IDENT_INT(5); + SUBTYPE S IS INTEGER RANGE 1 .. X; + TYPE AR1 IS ARRAY (S) OF INTEGER; + + SUBTYPE T IS INTEGER RANGE X .. 10; + TYPE AR2 IS ARRAY (T) OF INTEGER; + TYPE U IS ARRAY (INTEGER RANGE <>) OF INTEGER; + SUBTYPE V IS INTEGER RANGE 1 .. 10; + + TYPE R IS + RECORD + A : STRING (1 .. X); + B : STRING (X .. 10); + C : AR1; + D : AR2; + E : STRING (S); + F : U(T); + G : U(V RANGE 1 ..X); + H : STRING (POSITIVE RANGE X .. 10); + I : U(AR1'RANGE); + J : STRING (AR2'RANGE); + END RECORD; + RR : R; + + BEGIN + IF RR.A'LAST /= 5 OR RR.B'FIRST /= 5 OR + RR.C'LAST /= 5 OR RR.D'FIRST /= 5 OR + RR.E'LAST /= 5 OR RR.F'FIRST /= 5 OR + RR.G'LAST /= 5 OR RR.H'FIRST /= 5 OR + RR.I'LAST /= 5 OR RR.J'FIRST /= 5 THEN + + FAILED("WRONG VALUE FOR NON-STATIC BOUND"); + + END IF; + + END; + + RESULT; +END C37002A; diff --git a/gcc-4.9/gcc/testsuite/ada/acats/tests/c3/c37003a.ada b/gcc-4.9/gcc/testsuite/ada/acats/tests/c3/c37003a.ada new file mode 100644 index 000000000..5378f4ddd --- /dev/null +++ b/gcc-4.9/gcc/testsuite/ada/acats/tests/c3/c37003a.ada @@ -0,0 +1,198 @@ +-- C37003A.ADA + +-- Grant of Unlimited Rights +-- +-- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687, +-- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained +-- unlimited rights in the software and documentation contained herein. +-- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making +-- this public release, the Government intends to confer upon all +-- recipients unlimited rights equal to those held by the Government. +-- These rights include rights to use, duplicate, release or disclose the +-- released technical data and computer software in whole or in part, in +-- any manner and for any purpose whatsoever, and to have or permit others +-- to do so. +-- +-- DISCLAIMER +-- +-- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR +-- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED +-- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF 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 MULTIPLE COMPONENT DECLARATIONS ARE TREATED AS A SERIES +-- OF SINGLE COMNENT DECLARATIONS, I.E., THE COMPONENTS ALL HAVE THE +-- SAME TYPE AND ANY EXPRESSION USED IN CONSTRAINTS OR INITIALIZATIONS +-- IS EVALUATED ONCE FOR EACH COMPONENT. + +-- DAT 3/30/81 +-- SPS 10/26/82 +-- JWC 10/23/85 RENAMED FROM C37013A-AB.ADA. +-- ADDED TEST TO ENSURE THAT ANY EXPRESSION USED +-- IN A CONSTRAINT IS EVALUATED ONCE FOR EACH +-- COMPONENT. +-- JRK 11/15/85 ADDED INITIALIZATION EVALUATION CHECKS. + +WITH REPORT; USE REPORT; + +PROCEDURE C37003A IS + + X : INTEGER := 0; + + FUNCTION F RETURN INTEGER IS + BEGIN + X := X + 1; + RETURN X; + END F; + + PROCEDURE RESET IS + BEGIN + X := 0; + END RESET; + +BEGIN + TEST ("C37003A", "CHECK THAT MULTIPLE COMPONENT DECLARATIONS " & + "ARE TREATED AS A SERIES OF SINGLE COMPONENT " & + "DECLARATIONS"); + + DECLARE + + TYPE ARR IS ARRAY (INTEGER RANGE <>) OF INTEGER; + + TYPE REC1 IS RECORD + A1, A2 : ARR (1 .. F) := (OTHERS => F); + END RECORD; + + R1 : REC1 := (OTHERS => (OTHERS => 1)); + Y : INTEGER := X; + R1A : REC1; + + BEGIN + + IF R1.A1 = R1.A2 THEN -- TEST TO SEE IF THE COMPONENTS + NULL; -- ARE OF THE SAME TYPE. + END IF; + + IF Y /= 2 THEN + FAILED ("CONSTRAINT EXPRESSION NOT EVALUATED TWICE " & + "FOR ARRAYS"); + END IF; + + IF X /= 5 THEN + FAILED ("INITIALIZATION EXPRESSION NOT EVALUATED FOR " & + "EACH ARRAY COMPONENT"); + END IF; + + RESET; + + END; + + DECLARE + + TYPE REC2 IS RECORD + I1, I2 : INTEGER RANGE 1 .. F := F * IDENT_INT(0) + 1; + END RECORD; + + R2 : REC2 := (OTHERS => 1); + Y : INTEGER := X; + R2A : REC2; + + BEGIN + + IF R2.I1 = R2.I2 THEN -- TEST TO SEE IF THE COMPONENTS + NULL; -- ARE OF THE SAME TYPE. + END IF; + + IF Y /= 2 THEN + FAILED ("CONSTRAINT EXPRESSION NOT EVALUATED TWICE " & + "FOR SCALARS"); + END IF; + + IF X /= 4 THEN + FAILED ("INITIALIZATION EXPRESSION NOT EVALUATED FOR " & + "EACH SCALAR COMPONENT"); + END IF; + + RESET; + + END; + + DECLARE + + TYPE REC3X (DSC : INTEGER) IS RECORD + NULL; + END RECORD; + + TYPE REC3Y IS RECORD + I : INTEGER; + END RECORD; + + TYPE REC3 IS RECORD + RX1, RX2 : REC3X (F); + RY1, RY2 : REC3Y := (I => F); + END RECORD; + + R3 : REC3 := ((DSC => 1), (DSC => 2), (I => 0), (I => 0)); + Y : INTEGER := X; + R3A : REC3; + + BEGIN + + IF R3.RX1 = R3.RX2 THEN -- TEST TO SEE IF THE COMPONENTS + NULL; -- ARE OF THE SAME TYPE. + END IF; + + IF Y /= 2 THEN + FAILED ("CONSTRAINT EXPRESSION NOT EVALUATED TWICE " & + "FOR RECORDS"); + END IF; + + IF X /= 4 THEN + FAILED ("INITIALIZATION EXPRESSION NOT EVALUATED " & + "FOR EACH RECORD COMPONENT"); + END IF; + + RESET; + + END; + + DECLARE + + TYPE REC4X (DSC : INTEGER) IS RECORD + NULL; + END RECORD; + + TYPE ACR IS ACCESS REC4X; + TYPE ACI IS ACCESS INTEGER; + + TYPE REC4 IS RECORD + AC1, AC2 : ACR (F); + AC3, AC4 : ACI := NEW INTEGER'(F); + END RECORD; + + R4 : REC4 := (NULL, NULL, NULL, NULL); + Y : INTEGER := X; + R4A : REC4; + + BEGIN + + IF R4.AC1 = R4.AC2 THEN -- TEST TO SEE IF THE COMPONENTS + NULL; -- ARE OF THE SAME TYPE. + END IF; + + IF Y /= 2 THEN + FAILED ("CONSTRAINT EXPRESSION NOT EVALUATED TWICE " & + "FOR ACCESS"); + END IF; + + IF X /= 4 THEN + FAILED ("INITIALIZATION EXPRESSION NOT EVALUATED " & + "FOR EACH ACCESS COMPONENT"); + END IF; + + END; + + RESULT; +END C37003A; diff --git a/gcc-4.9/gcc/testsuite/ada/acats/tests/c3/c37003b.ada b/gcc-4.9/gcc/testsuite/ada/acats/tests/c3/c37003b.ada new file mode 100644 index 000000000..49ebdc0ed --- /dev/null +++ b/gcc-4.9/gcc/testsuite/ada/acats/tests/c3/c37003b.ada @@ -0,0 +1,66 @@ +-- C37003B.ADA + +-- Grant of Unlimited Rights +-- +-- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687, +-- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained +-- unlimited rights in the software and documentation contained herein. +-- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making +-- this public release, the Government intends to confer upon all +-- recipients unlimited rights equal to those held by the Government. +-- These rights include rights to use, duplicate, release or disclose the +-- released technical data and computer software in whole or in part, in +-- any manner and for any purpose whatsoever, and to have or permit others +-- to do so. +-- +-- DISCLAIMER +-- +-- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR +-- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED +-- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE +-- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE +-- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A +-- PARTICULAR PURPOSE OF SAID MATERIAL. +--* +-- OBJECTIVE: +-- CHECK THAT FOR A RECORD WITH MULTIPLE DISCRIMINANTS WHICH HAVE +-- DEFAULT EXPRESSIONS, THE EXPRESSIONS ARE EVALUATED ONCE FOR +-- EACH DISCRIMINANT IN THE ASSOCIATION. + +-- HISTORY: +-- DHH 08/04/88 CREATED ORIGINAL TEST. + +WITH REPORT; USE REPORT; +PROCEDURE C37003B IS + + X : INTEGER := 0; + + FUNCTION F1 RETURN INTEGER IS + BEGIN + X := X + 1; + RETURN X; + END F1; + +BEGIN + TEST("C37003B", "CHECK THAT FOR A RECORD WITH MULTIPLE " & + "DISCRIMINANTS WHICH HAVE DEFAULT EXPRESSIONS, " & + "THE EXPRESSIONS ARE EVALUATED ONCE FOR EACH " & + "DISCRIMINANT IN THE ASSOCIATION"); + + DECLARE + TYPE REC(D1, D2, D3, D4, D5 : INTEGER := F1) IS + RECORD + Y : INTEGER := (D1 + D2 + D3 + D4 + D5); + END RECORD; + + REC_F1 : REC; + + BEGIN + IF REC_F1.Y /= IDENT_INT(15) THEN + FAILED("MULTIPLE DISCRIMINANTS NOT EVALUATED " & + "SEPARATELY"); + END IF; + END; + + RESULT; +END C37003B; diff --git a/gcc-4.9/gcc/testsuite/ada/acats/tests/c3/c37005a.ada b/gcc-4.9/gcc/testsuite/ada/acats/tests/c3/c37005a.ada new file mode 100644 index 000000000..0983fe00e --- /dev/null +++ b/gcc-4.9/gcc/testsuite/ada/acats/tests/c3/c37005a.ada @@ -0,0 +1,92 @@ +-- C37005A.ADA + +-- Grant of Unlimited Rights +-- +-- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687, +-- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained +-- unlimited rights in the software and documentation contained herein. +-- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making +-- this public release, the Government intends to confer upon all +-- recipients unlimited rights equal to those held by the Government. +-- These rights include rights to use, duplicate, release or disclose the +-- released technical data and computer software in whole or in part, in +-- any manner and for any purpose whatsoever, and to have or permit others +-- to do so. +-- +-- DISCLAIMER +-- +-- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR +-- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED +-- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF 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 SCALAR RECORD COMPONENTS MAY HAVE NON-STATIC +-- RANGE CONSTRAINTS OR DEFAULT INITIAL VALUES. + +-- DAT 3/6/81 +-- JWC 6/28/85 RENAMED TO -AB +-- EDS 7/16/98 AVOID OPTIMIZATION + +WITH REPORT; +PROCEDURE C37005A IS + + USE REPORT; + +BEGIN + TEST ("C37005A", "SCALAR RECORD COMPONENTS MAY HAVE NON-STATIC" + & " RANGE CONSTRAINTS OR DEFAULT INITIAL VALUES"); + + DECLARE + SUBTYPE DT IS INTEGER RANGE IDENT_INT (1) .. IDENT_INT (5); + L : INTEGER := IDENT_INT (DT'FIRST); + R : INTEGER := IDENT_INT (DT'LAST); + SUBTYPE DT2 IS INTEGER RANGE L .. R; + M : INTEGER := (L + R) / 2; + + TYPE REC IS + RECORD + C1 : INTEGER := M; + C2 : DT2 := (L + R) / 2; + C3 : BOOLEAN RANGE (L < M) .. (R > M) + := IDENT_BOOL (TRUE); + C4 : INTEGER RANGE L .. R := DT'FIRST; + END RECORD; + + R1, R2 : REC := ((L+R)/2, M, M IN DT, L); + R3 : REC; + BEGIN + IF R3 /= R1 + THEN + FAILED ("INCORRECT RECORD VALUES"); + END IF; + + R3 := (R2.C2, R2.C1, R3.C3, R); -- CONSTRAINTS CHECKED BY := + IF EQUAL(IDENT_INT(1), 2) THEN + FAILED("IMPOSSIBLE " & INTEGER'IMAGE(R3.C1)); --USE R3 + END IF; + + BEGIN + R3 := (M, M, IDENT_BOOL (FALSE), M); -- RAISES CON_ERR. + FAILED ("CONSTRAINT ERROR NOT RAISED " & INTEGER'IMAGE(R3.C1)); + EXCEPTION + WHEN CONSTRAINT_ERROR => NULL; + WHEN OTHERS => FAILED ("WRONG EXCEPTION"); + END; + + FOR I IN DT LOOP + R3 := (I, I, I /= 100, I); + R1.C2 := I; + IF EQUAL(IDENT_INT(1), 2) THEN + FAILED("IMPOSSIBLE " & + INTEGER'IMAGE(R3.C1 + R1.C2)); --USE R3, R1 + END IF; + END LOOP; + + EXCEPTION + WHEN OTHERS => FAILED ("INVALID EXCEPTION"); + END; + + RESULT; +END C37005A; diff --git a/gcc-4.9/gcc/testsuite/ada/acats/tests/c3/c37006a.ada b/gcc-4.9/gcc/testsuite/ada/acats/tests/c3/c37006a.ada new file mode 100644 index 000000000..ac926d1f4 --- /dev/null +++ b/gcc-4.9/gcc/testsuite/ada/acats/tests/c3/c37006a.ada @@ -0,0 +1,272 @@ +-- C37006A.ADA + +-- Grant of Unlimited Rights +-- +-- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687, +-- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained +-- unlimited rights in the software and documentation contained herein. +-- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making +-- this public release, the Government intends to confer upon all +-- recipients unlimited rights equal to those held by the Government. +-- These rights include rights to use, duplicate, release or disclose the +-- released technical data and computer software in whole or in part, in +-- any manner and for any purpose whatsoever, and to have or permit others +-- to do so. +-- +-- DISCLAIMER +-- +-- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR +-- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED +-- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE +-- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE +-- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A +-- PARTICULAR PURPOSE OF SAID MATERIAL. +--* +-- FOR A COMPONENT OF A RECORD, ACCESS, OR PRIVATE TYPE, OR FOR A +-- LIMITED PRIVATE COMPONENT, CHECK THAT A NON-STATIC EXPRESSION CAN +-- BE USED IN A DISCRIMINANT CONSTRAINT OR (EXCEPTING LIMITED PRIVATE +-- COMPONENTS) IN SPECIFYING A DEFAULT INITIAL VALUE. + +-- R.WILLIAMS 8/28/86 + +WITH REPORT; USE REPORT; +PROCEDURE C37006A IS + + SUBTYPE INT IS INTEGER RANGE 0 .. 100; + + TYPE ARR IS ARRAY (INT RANGE <>) OF INTEGER; + + TYPE REC1 (D1, D2 : INT) IS + RECORD + A : ARR (D1 .. D2); + END RECORD; + + TYPE REC1_NAME IS ACCESS REC1; + + PROCEDURE CHECK (AR : ARR; STR : STRING) IS + BEGIN + IF AR'FIRST /= 1 OR AR'LAST /= 2 THEN + FAILED ( "INCORRECT BOUNDS FOR R.COMP.A IN COMPONENT " & + "OF " & STR & " TYPE"); + ELSIF AR /= (3, 4) THEN + FAILED ( "INITIALIZATION OF R.COMP.A IN COMPONENT OF " & + STR & " TYPE FAILED" ); + END IF; + END CHECK; + + PACKAGE PACK IS + TYPE PRIV (D1, D2 : INT) IS PRIVATE; + TYPE LIM (D1, D2 : INT) IS LIMITED PRIVATE; + FUNCTION PRIV_FUN (PARM1, PARM2 : INTEGER) RETURN PRIV; + PROCEDURE PRIV_CHECK (R : PRIV); + PROCEDURE LIM_CHECK (R : LIM); + + PRIVATE + TYPE PRIV (D1, D2 : INT) IS + RECORD + A : ARR (D1 .. D2); + END RECORD; + + TYPE LIM (D1, D2 : INT) IS + RECORD + A : ARR (D1 .. D2); + END RECORD; + END PACK; + + PACKAGE BODY PACK IS + + FUNCTION PRIV_FUN (PARM1, PARM2 : INTEGER) RETURN PRIV IS + BEGIN + RETURN (IDENT_INT (1), IDENT_INT (2), + ARR'(1 => 3, 2 => 4)); + END PRIV_FUN; + + PROCEDURE PRIV_CHECK (R : PRIV) IS + BEGIN + CHECK (R.A, "PRIVATE TYPE" ); + END PRIV_CHECK; + + PROCEDURE LIM_CHECK (R : LIM) IS + BEGIN + IF R.A'FIRST /= 1 OR R.A'LAST /= 2 THEN + FAILED ( "INCORRECT BOUNDS FOR R.COMP.A IN " & + "COMPONENT OF LIMITED PRIVATE TYPE"); + END IF; + END LIM_CHECK; + END PACK; + + USE PACK; + +BEGIN + + TEST ( "C37006A", "FOR A COMPONENT OF A RECORD, ACCESS, " & + "OR PRIVATE TYPE, OR FOR A LIMITED PRIVATE " & + "COMPONENT, CHECK THAT A NON-STATIC " & + "EXPRESSION CAN BE USED IN A DISCRIMINANT " & + "CONSTRAINT OR (EXCEPTING LIMITED PRIVATE " & + "COMPONENTS) IN SPECIFYING A DEFAULT " & + "INITIAL VALUE" ); + + BEGIN + DECLARE + + TYPE REC2 IS + RECORD + COMP : REC1 (IDENT_INT (1), IDENT_INT (2)) := + (IDENT_INT (1), IDENT_INT (2), + ARR'(1 => 3, 2 => 4)); + END RECORD; + + R : REC2; + + BEGIN + IF R.COMP.D1 = 1 AND R.COMP.D2 = 2 THEN + CHECK (R.COMP.A, "RECORD"); + ELSE + FAILED ( "INCORRECT VALUE FOR DISCRIMINANTS " & + "OF RECORD TYPE COMPONENT" ); + END IF; + + EXCEPTION + WHEN CONSTRAINT_ERROR => + FAILED ( "CONSTRAINT_ERROR RAISED IN STATEMENT " & + "SEQUENCE FOLLOWING DECLARATION OF " & + "RECORD TYPE COMPONENT" ); + WHEN OTHERS => + FAILED ( "OTHER EXCEPTION RAISED IN STATEMENT " & + "SEQUENCE FOLLOWING DECLARATION OF " & + "RECORD TYPE COMPONENT" ); + END; + + EXCEPTION + WHEN CONSTRAINT_ERROR => + FAILED ( "CONSTRAINT_ERROR RAISED BY DECLARATION " & + "OF RECORD TYPE COMPONENT" ); + WHEN OTHERS => + FAILED ( "OTHER EXCEPTION RAISED BY DECLARATION " & + "OF RECORD TYPE COMPONENT" ); + END; + + BEGIN + DECLARE + + TYPE REC2 IS + RECORD + COMP : REC1_NAME (IDENT_INT (1), + IDENT_INT (2)) := + NEW REC1'(IDENT_INT (1), + IDENT_INT (2), + ARR'(1 => 3, 2 => 4)); + END RECORD; + + R : REC2; + + BEGIN + IF R.COMP.D1 = 1 AND R.COMP.D2 = 2 THEN + CHECK (R.COMP.A, "ACCESS"); + ELSE + FAILED ( "INCORRECT VALUE FOR DISCRIMINANTS " & + "OF ACCESS TYPE COMPONENT" ); + END IF; + + EXCEPTION + WHEN CONSTRAINT_ERROR => + FAILED ( "CONSTRAINT_ERROR RAISED IN STATEMENT " & + "SEQUENCE FOLLOWING DECLARATION OF " & + "ACCESS TYPE COMPONENT" ); + WHEN OTHERS => + FAILED ( "OTHER EXCEPTION RAISED IN STATEMENT " & + "SEQUENCE FOLLOWING DECLARATION OF " & + "ACCESS TYPE COMPONENT" ); + END; + + EXCEPTION + WHEN CONSTRAINT_ERROR => + FAILED ( "CONSTRAINT_ERROR RAISED BY DECLARATION " & + "OF ACCESS TYPE COMPONENT" ); + WHEN OTHERS => + FAILED ( "OTHER EXCEPTION RAISED BY DECLARATION " & + "OF ACCESS TYPE COMPONENT" ); + END; + + BEGIN + DECLARE + + TYPE REC2 IS + RECORD + COMP : PRIV (IDENT_INT (1), IDENT_INT (2)) := + PRIV_FUN (IDENT_INT (1), + IDENT_INT (2)); + END RECORD; + + R : REC2; + + BEGIN + IF R.COMP.D1 = 1 AND R.COMP.D2 = 2 THEN + PRIV_CHECK (R.COMP); + ELSE + FAILED ( "INCORRECT VALUE FOR DISCRIMINANTS " & + "OF PRIVATE TYPE COMPONENT" ); + END IF; + + EXCEPTION + WHEN CONSTRAINT_ERROR => + FAILED ( "CONSTRAINT_ERROR RAISED IN STATEMENT " & + "SEQUENCE FOLLOWING DECLARATION OF " & + "PRIVATE TYPE COMPONENT" ); + WHEN OTHERS => + FAILED ( "OTHER EXCEPTION RAISED IN STATEMENT " & + "SEQUENCE FOLLOWING DECLARATION OF " & + "PRIVATE TYPE COMPONENT" ); + END; + + EXCEPTION + WHEN CONSTRAINT_ERROR => + FAILED ( "CONSTRAINT_ERROR RAISED BY DECLARATION " & + "OF PRIVATE TYPE COMPONENT" ); + WHEN OTHERS => + FAILED ( "OTHER EXCEPTION RAISED BY DECLARATION " & + "OF PRIVATE TYPE COMPONENT" ); + END; + + BEGIN + DECLARE + + TYPE REC2 IS + RECORD + COMP : LIM (IDENT_INT (1), IDENT_INT (2)); + END RECORD; + + R : REC2; + + BEGIN + IF R.COMP.D1 = 1 AND R.COMP.D2 = 2 THEN + LIM_CHECK (R.COMP); + ELSE + FAILED ( "INCORRECT VALUE FOR DISCRIMINANTS " & + "OF LIM PRIV TYPE COMPONENT" ); + END IF; + + EXCEPTION + WHEN CONSTRAINT_ERROR => + FAILED ( "CONSTRAINT_ERROR RAISED IN STATEMENT " & + "SEQUENCE FOLLOWING DECLARATION OF " & + " LIM PRIV TYPE COMPONENT" ); + WHEN OTHERS => + FAILED ( "OTHER EXCEPTION RAISED IN STATEMENT " & + "SEQUENCE FOLLOWING DECLARATION OF " & + " LIM PRIV TYPE COMPONENT" ); + END; + + EXCEPTION + WHEN CONSTRAINT_ERROR => + FAILED ( "CONSTRAINT_ERROR RAISED BY DECLARATION " & + "OF LIM PRIV TYPE COMPONENT" ); + WHEN OTHERS => + FAILED ( "OTHER EXCEPTION RAISED BY DECLARATION " & + "OF LIM PRIV TYPE COMPONENT" ); + END; + + RESULT; + +END C37006A; diff --git a/gcc-4.9/gcc/testsuite/ada/acats/tests/c3/c37008a.ada b/gcc-4.9/gcc/testsuite/ada/acats/tests/c3/c37008a.ada new file mode 100644 index 000000000..5546ae0ff --- /dev/null +++ b/gcc-4.9/gcc/testsuite/ada/acats/tests/c3/c37008a.ada @@ -0,0 +1,270 @@ +-- C37008A.ADA + +-- Grant of Unlimited Rights +-- +-- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687, +-- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained +-- unlimited rights in the software and documentation contained herein. +-- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making +-- this public release, the Government intends to confer upon all +-- recipients unlimited rights equal to those held by the Government. +-- These rights include rights to use, duplicate, release or disclose the +-- released technical data and computer software in whole or in part, in +-- any manner and for any purpose whatsoever, and to have or permit others +-- to do so. +-- +-- DISCLAIMER +-- +-- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR +-- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED +-- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF 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 SPECIFYING AN INVALID DEFAULT INITIALIZATION +-- RAISES CONSTRAINT_ERROR WHEN AN OBJECT IS DECLARED. + +-- DAT 3/6/81 +-- SPS 10/26/82 +-- RJW 1/9/86 - REVISED COMMENTS. ADDED 'IDENT_INT'. +-- EDS 7/22/98 AVOID OPTIMIZATION + +WITH REPORT; +USE REPORT; +PROCEDURE C37008A IS +BEGIN + TEST ("C37008A", "CHECK THAT INVALID DEFAULT RECORD" + & " COMPONENT INITIALIZATIONS RAISE" + & " CONSTRAINT_ERROR"); + + BEGIN + DECLARE + TYPE R1 IS RECORD + C1 : INTEGER RANGE 1 .. 5 := IDENT_INT (0); + END RECORD; + REC1 : R1; + BEGIN + FAILED ("NO EXCEPTION RAISED 1 " & INTEGER'IMAGE(REC1.C1)); + END; + EXCEPTION + WHEN CONSTRAINT_ERROR => NULL; + WHEN OTHERS => FAILED ("WRONG EXCEPTION RAISED 1"); + END; + + BEGIN + DECLARE + TYPE R IS RECORD + C : CHARACTER RANGE 'A' .. 'Y' := 'Z'; + END RECORD; + REC2 : R; + BEGIN + FAILED ("NO EXCEPTION RAISED 1A " & (REC2.C)); + END; + EXCEPTION + WHEN CONSTRAINT_ERROR => NULL; + WHEN OTHERS => FAILED ("WRONG EXCEPTION RAISED 1A"); + END; + + BEGIN + DECLARE + TYPE R2 IS RECORD + C2 : BOOLEAN RANGE FALSE .. FALSE := TRUE; + END RECORD; + REC3 : R2; + BEGIN + FAILED ("NO EXCEPTION RAISED 2 " & BOOLEAN'IMAGE(REC3.C2)); + END; + EXCEPTION + WHEN CONSTRAINT_ERROR => NULL; + WHEN OTHERS => FAILED ("WRONG EXCEPTION RAISED 2"); + END; + + BEGIN + DECLARE + TYPE E IS (E1, E2, E3); + TYPE R IS RECORD + C : E RANGE E2 .. E3 := E1; + END RECORD; + REC4 : R; + BEGIN + FAILED ("NO EXCEPTION RAISED 2A " & E'IMAGE(REC4.C)); + END; + EXCEPTION + WHEN CONSTRAINT_ERROR => NULL; + WHEN OTHERS => FAILED ("WRONG EXCEPTION RAISED 2A"); + END; + + BEGIN + DECLARE + TYPE R3 IS RECORD + C3 : INTEGER RANGE 1 .. 5; + END RECORD; + REC5 : R3; + TYPE R3A IS RECORD + C3A : R3 := (OTHERS => IDENT_INT (6)); + END RECORD; + REC6 : R3A; + BEGIN + FAILED ("NO EXCEPTION RAISED 3 " & + INTEGER'IMAGE(REC6.C3A.C3)); + END; + EXCEPTION + WHEN CONSTRAINT_ERROR => NULL; + WHEN OTHERS => FAILED ("WRONG EXCEPTION RAISED 3"); + END; + + BEGIN + DECLARE + TYPE ARR IS ARRAY (1..3) OF INTEGER RANGE 8..9; + TYPE R4 IS RECORD + C4 : ARR + := (1 => 8, 2 => 9, 3 => 10); + END RECORD; + REC7 : R4; + BEGIN + FAILED ("NO EXCEPTION RAISED 4 " & + INTEGER'IMAGE(REC7.C4(1))); + END; + EXCEPTION + WHEN CONSTRAINT_ERROR => NULL; + WHEN OTHERS => FAILED ("WRONG EXCEPTION RAISED 4"); + END; + + BEGIN + DECLARE + TYPE A IS ARRAY (NATURAL RANGE <> ) + OF INTEGER RANGE 1 .. 5; + + TYPE AA IS ACCESS A; + + TYPE R5 IS RECORD + C5 : AA := NEW A' (4, 5, 6); + END RECORD; + REC8 : R5; + BEGIN + FAILED ("NO EXCEPTION RAISED 5 " & + INTEGER'IMAGE(REC8.C5(1))); + END; + EXCEPTION + WHEN CONSTRAINT_ERROR => NULL; + WHEN OTHERS => FAILED ("WRONG EXCEPTION RAISED 5"); + END; + + BEGIN + DECLARE + TYPE A IS ARRAY (NATURAL RANGE <> ) + OF INTEGER RANGE 1 .. 5; + + TYPE AA IS ACCESS A (1 .. 3); + + TYPE R6 IS RECORD + C6 : AA := NEW A' (4, 4, 4, 4); + END RECORD; + REC9 : R6; + BEGIN + FAILED ("NO EXCEPTION RAISED 6 " & + INTEGER'IMAGE(REC9.C6(1))); + END; + EXCEPTION + WHEN CONSTRAINT_ERROR => NULL; + WHEN OTHERS => FAILED ("WRONG EXCEPTION RAISED 6"); + END; + + BEGIN + DECLARE + TYPE AI IS ACCESS INTEGER RANGE 6 .. 8; + + TYPE R7 IS RECORD + C7 : AI := NEW INTEGER' (5); + END RECORD; + REC10 : R7; + BEGIN + FAILED ("NO EXCEPTION RAISED 7 " & + INTEGER'IMAGE(REC10.C7.ALL)); + END; + EXCEPTION + WHEN CONSTRAINT_ERROR => NULL; + WHEN OTHERS => FAILED ("WRONG EXCEPTION RAISED 7"); + END; + + BEGIN + DECLARE + TYPE UA IS ARRAY (NATURAL RANGE <> ) + OF INTEGER RANGE 3 .. 5; + + SUBTYPE CA IS UA (7 .. 8); + + TYPE R8 IS RECORD + C8 : CA := (6 .. 8 => 4); + END RECORD; + REC11 : R8; + BEGIN + FAILED ("NO EXCEPTION RAISED 8 " & + INTEGER'IMAGE(REC11.C8(7))); + END; + EXCEPTION + WHEN CONSTRAINT_ERROR => NULL; + WHEN OTHERS => FAILED ("WRONG EXCEPTION RAISED 8"); + END; + + BEGIN + DECLARE + TYPE UA IS ARRAY (NATURAL RANGE <> ) + OF INTEGER RANGE 3 .. IDENT_INT(5); + + TYPE R9 IS RECORD + C9 : UA (11 .. 11) := (11 => 6); + END RECORD; + REC12 : R9; + BEGIN + FAILED ("NO EXCEPTION RAISED 9 " & + INTEGER'IMAGE(REC12.C9(11))); + END; + EXCEPTION + WHEN CONSTRAINT_ERROR => NULL; + WHEN OTHERS => FAILED ("WRONG EXCEPTION RAISED 9"); + END; + + BEGIN + DECLARE + TYPE A IS ARRAY (NATURAL RANGE <> ) + OF INTEGER RANGE 1 .. IDENT_INT (5); + + TYPE AA IS ACCESS A; + + TYPE R10 IS RECORD + C10 : AA := NEW A '(4, 5, 6); + END RECORD; + REC13 : R10; + BEGIN + FAILED ("NO EXCEPTION RAISED 10 " & + INTEGER'IMAGE(REC13.C10(1))); + END; + EXCEPTION + WHEN CONSTRAINT_ERROR => NULL; + WHEN OTHERS => FAILED ("WRONG EXCEPTION RAISED 10"); + END; + + BEGIN + DECLARE + TYPE A IS ARRAY (NATURAL RANGE <> ) + OF INTEGER RANGE 1 .. 5; + + TYPE AA IS ACCESS A (IDENT_INT (1) .. IDENT_INT (3)); + + TYPE R11 IS RECORD + C11 : AA := NEW A '(4, 4, 4, 4); + END RECORD; + REC14 : R11; + BEGIN + FAILED ("NO EXCEPTION RAISED 11 " & + INTEGER'IMAGE(REC14.C11(1))); + END; + EXCEPTION + WHEN CONSTRAINT_ERROR => NULL; + WHEN OTHERS => FAILED ("WRONG EXCEPTION RAISED 11"); + END; + + RESULT; +END C37008A; diff --git a/gcc-4.9/gcc/testsuite/ada/acats/tests/c3/c37008b.ada b/gcc-4.9/gcc/testsuite/ada/acats/tests/c3/c37008b.ada new file mode 100644 index 000000000..369f08cf5 --- /dev/null +++ b/gcc-4.9/gcc/testsuite/ada/acats/tests/c3/c37008b.ada @@ -0,0 +1,232 @@ +-- C37008B.ADA + +-- Grant of Unlimited Rights +-- +-- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687, +-- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained +-- unlimited rights in the software and documentation contained herein. +-- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making +-- this public release, the Government intends to confer upon all +-- recipients unlimited rights equal to those held by the Government. +-- These rights include rights to use, duplicate, release or disclose the +-- released technical data and computer software in whole or in part, in +-- any manner and for any purpose whatsoever, and to have or permit others +-- to do so. +-- +-- DISCLAIMER +-- +-- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR +-- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED +-- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF 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 NO CONSTRAINT ERROR IS RAISED FOR AN UNUSED TYPE +-- DECLARATION WITH AN INVALID DEFAULT VALUE + +-- JBG 9/11/81 +-- SPS 10/25/82 + +WITH REPORT; +USE REPORT; +PROCEDURE C37008B IS +BEGIN + TEST ("C37008B", "CHECK THAT INVALID DEFAULT RECORD" + & " COMPONENT INITIALIZATIONS DO NOT RAISE" + & " CONSTRAINT_ERROR"); + + BEGIN + DECLARE + TYPE R1 IS RECORD + C1 : INTEGER RANGE 1 .. 5 := 0; + END RECORD; + BEGIN + NULL; + END; + EXCEPTION + WHEN OTHERS => FAILED ("EXCEPTION RAISED 1"); + END; + + BEGIN + DECLARE + TYPE R IS RECORD + C : CHARACTER RANGE 'A' .. 'Y' := 'Z'; + END RECORD; + BEGIN + NULL; + END; + EXCEPTION + WHEN OTHERS => FAILED ("EXCEPTION RAISED 1A"); + END; + + BEGIN + DECLARE + TYPE R2 IS RECORD + C2 : BOOLEAN RANGE FALSE .. FALSE := TRUE; + END RECORD; + BEGIN + NULL; + END; + EXCEPTION + WHEN OTHERS => FAILED ("EXCEPTION RAISED 2"); + END; + + BEGIN + DECLARE + TYPE E IS (E1, E2, E3); + TYPE R IS RECORD + C : E RANGE E2 .. E3 := E1; + END RECORD; + BEGIN + NULL; + END; + EXCEPTION + WHEN OTHERS => FAILED ("EXCEPTION RAISED 2A"); + END; + + BEGIN + DECLARE + TYPE R3 IS RECORD + C3 : INTEGER RANGE 1 .. 5; + END RECORD; + TYPE R3A IS RECORD + C3A : R3 := (OTHERS => 6); + END RECORD; + BEGIN + NULL; + END; + EXCEPTION + WHEN OTHERS => FAILED ("EXCEPTION RAISED 3"); + END; + + BEGIN + DECLARE + TYPE ARR IS ARRAY (1..3) OF INTEGER RANGE 8..9; + TYPE R4 IS RECORD + C4 : ARR + := (1 => 8, 2 => 9, 3 => 10); + END RECORD; + BEGIN + NULL; + END; + EXCEPTION + WHEN OTHERS => FAILED ("EXCEPTION RAISED 4"); + END; + + BEGIN + DECLARE + TYPE A IS ARRAY (NATURAL RANGE <> ) + OF INTEGER RANGE 1 .. 5; + + TYPE AA IS ACCESS A; + + TYPE R5 IS RECORD + C5 : AA := NEW A'(4, 5, 6); + END RECORD; + BEGIN + NULL; + END; + EXCEPTION + WHEN OTHERS => FAILED ("EXCEPTION RAISED 5"); + END; + + BEGIN + DECLARE + TYPE A IS ARRAY (NATURAL RANGE <> ) + OF INTEGER RANGE 1 .. 5; + + TYPE AA IS ACCESS A (1 .. 3); + + TYPE R6 IS RECORD + C6 : AA := NEW A'(4, 4, 4, 4); + END RECORD; + BEGIN + NULL; + END; + EXCEPTION + WHEN OTHERS => FAILED ("EXCEPTION RAISED 6"); + END; + + BEGIN + DECLARE + TYPE AI IS ACCESS INTEGER RANGE 6 .. 8; + + TYPE R7 IS RECORD + C7 : AI := NEW INTEGER'(5); + END RECORD; + BEGIN + NULL; + END; + EXCEPTION + WHEN OTHERS => FAILED ("EXCEPTION RAISED 7"); + END; + + BEGIN + DECLARE + TYPE UA IS ARRAY (NATURAL RANGE <> ) + OF INTEGER RANGE 3 .. 5; + + SUBTYPE CA IS UA (7 .. 8); + + TYPE R8 IS RECORD + C8 : CA := (6 .. 8 => 4); + END RECORD; + BEGIN + NULL; + END; + EXCEPTION + WHEN OTHERS => FAILED ("EXCEPTION RAISED 8"); + END; + + BEGIN + DECLARE + TYPE UA IS ARRAY (NATURAL RANGE <> ) + OF INTEGER RANGE 3 .. IDENT_INT(5); + + TYPE R9 IS RECORD + C9 : UA (11 .. 11) := (11 => 6); + END RECORD; + BEGIN + NULL; + END; + EXCEPTION + WHEN OTHERS => FAILED ("EXCEPTION RAISED 9"); + END; + + BEGIN + DECLARE + TYPE A IS ARRAY (NATURAL RANGE <> ) + OF INTEGER RANGE 1 .. IDENT_INT (5); + + TYPE AA IS ACCESS A; + + TYPE R10 IS RECORD + C10 : AA := NEW A'(4, 5, 6); + END RECORD; + BEGIN + NULL; + END; + EXCEPTION + WHEN OTHERS => FAILED ("EXCEPTION RAISED 10"); + END; + + BEGIN + DECLARE + TYPE A IS ARRAY (NATURAL RANGE <> ) + OF INTEGER RANGE 1 .. 5; + + TYPE AA IS ACCESS A (IDENT_INT (1) .. IDENT_INT (3)); + + TYPE R11 IS RECORD + C11 : AA := NEW A'(4, 4, 4, 4); + END RECORD; + BEGIN + NULL; + END; + EXCEPTION + WHEN OTHERS => FAILED ("EXCEPTION RAISED 11"); + END; + + RESULT; +END C37008B; diff --git a/gcc-4.9/gcc/testsuite/ada/acats/tests/c3/c37009a.ada b/gcc-4.9/gcc/testsuite/ada/acats/tests/c3/c37009a.ada new file mode 100644 index 000000000..bdb3d810c --- /dev/null +++ b/gcc-4.9/gcc/testsuite/ada/acats/tests/c3/c37009a.ada @@ -0,0 +1,195 @@ +-- C37009A.ADA + +-- Grant of Unlimited Rights +-- +-- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687, +-- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained +-- unlimited rights in the software and documentation contained herein. +-- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making +-- this public release, the Government intends to confer upon all +-- recipients unlimited rights equal to those held by the Government. +-- These rights include rights to use, duplicate, release or disclose the +-- released technical data and computer software in whole or in part, in +-- any manner and for any purpose whatsoever, and to have or permit others +-- to do so. +-- +-- DISCLAIMER +-- +-- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR +-- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED +-- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE +-- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE +-- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A +-- PARTICULAR PURPOSE OF SAID MATERIAL. +--* +-- OBJECTIVE: +-- CHECK THAT AN UNCONSTRAINED RECORD TYPE CAN BE USED TO DECLARE A +-- RECORD COMPONENT THAT CAN BE INITIALIZED WITH AN APPROPRIATE +-- EXPLICIT OR DEFAULT VALUE. + +-- HISTORY: +-- DHH 02/01/88 CREATED ORIGINAL TEST. + +WITH REPORT; USE REPORT; + +PROCEDURE C37009A IS + + TYPE FLOAT IS DIGITS 5; + TYPE COLOR IS (RED, YELLOW, BLUE); + + TYPE COMPONENT IS + RECORD + I : INTEGER := 1; + X : FLOAT := 3.5; + BOL : BOOLEAN := FALSE; + FIRST : COLOR := RED; + END RECORD; + TYPE COMP_DIS(A : INTEGER := 1) IS + RECORD + I : INTEGER := 1; + X : FLOAT := 3.5; + BOL : BOOLEAN := FALSE; + FIRST : COLOR := RED; + END RECORD; + SUBTYPE SMAL_INTEGER IS INTEGER RANGE 1 .. 10; + TYPE LIST IS ARRAY(INTEGER RANGE <>) OF FLOAT; + + TYPE DISCRIM(P : SMAL_INTEGER := 2) IS + RECORD + A : LIST(1 .. P) := (1 .. P => 1.25); + END RECORD; + + TYPE REC_T IS -- EXPLICIT INIT. + RECORD + T : COMPONENT := (5, 6.0, TRUE, YELLOW); + U : DISCRIM(3) := (3, (1 .. 3 => 2.25)); + L : COMP_DIS(5) := (A => 5, I => 5, X => 6.0, + BOL =>TRUE, FIRST => YELLOW); + END RECORD; + + TYPE REC_DEF_T IS -- DEFAULT INIT. + RECORD + T : COMPONENT; + U : DISCRIM; + L : COMP_DIS; + END RECORD; + + REC : REC_T; + REC_DEF : REC_DEF_T; + + FUNCTION IDENT_FLT(X : FLOAT) RETURN FLOAT IS + BEGIN + IF EQUAL(3,3) THEN + RETURN X; + ELSE + RETURN 0.0; + END IF; + END IDENT_FLT; + + FUNCTION IDENT_ENUM(X : COLOR) RETURN COLOR IS + BEGIN + IF EQUAL(3,3) THEN + RETURN X; + ELSE + RETURN BLUE; + END IF; + END IDENT_ENUM; + +BEGIN + TEST("C37009A", "CHECK THAT AN UNCONSTRAINED RECORD TYPE CAN " & + "BE USED TO DECLARE A RECORD COMPONENT THAT " & + "CAN BE INITIALIZED WITH AN APPROPRIATE " & + "EXPLICIT OR DEFAULT VALUE"); + + IF REC_DEF.T.I /= IDENT_INT(1) THEN + FAILED("INCORRECT DEFAULT INITIALIZATION OF INTEGER"); + END IF; + + IF IDENT_BOOL(REC_DEF.T.BOL) THEN + FAILED("INCORRECT DEFAULT INITIALIZATION OF BOOLEAN"); + END IF; + + IF REC_DEF.T.X /= IDENT_FLT(3.5) THEN + FAILED("INCORRECT DEFAULT INITIALIZATION OF REAL"); + END IF; + + IF REC_DEF.T.FIRST /= IDENT_ENUM(RED) THEN + FAILED("INCORRECT DEFAULT INITIALIZATION OF ENUMERATION"); + END IF; + + FOR I IN 1 .. 2 LOOP + IF REC_DEF.U.A(I) /= IDENT_FLT(1.25) THEN + FAILED("INCORRECT DEFAULT INITIALIZATION OF ARRAY " & + "POSITION " & INTEGER'IMAGE(I)); + END IF; + END LOOP; + + IF REC_DEF.L.A /= IDENT_INT(1) THEN + FAILED("INCORRECT DEFAULT INITIALIZATION OF DISCRIMINANT " & + "- L"); + END IF; + + IF REC_DEF.L.I /= IDENT_INT(1) THEN + FAILED("INCORRECT DEFAULT INITIALIZATION OF INTEGER - L"); + END IF; + + IF IDENT_BOOL(REC_DEF.L.BOL) THEN + FAILED("INCORRECT DEFAULT INITIALIZATION OF BOOLEAN - L"); + END IF; + + IF REC_DEF.L.X /= IDENT_FLT(3.5) THEN + FAILED("INCORRECT DEFAULT INITIALIZATION OF REAL - L"); + END IF; + + IF REC_DEF.L.FIRST /= IDENT_ENUM(RED) THEN + FAILED("INCORRECT DEFAULT INITIALIZATION OF ENUMERATION - L"); + END IF; +-------------------------------------------------------------------- + IF REC.T.I /= IDENT_INT(5) THEN + FAILED("INCORRECT EXPLICIT INITIALIZATION OF INTEGER"); + END IF; + + IF NOT IDENT_BOOL(REC.T.BOL) THEN + FAILED("INCORRECT EXPLICIT INITIALIZATION OF BOOLEAN"); + END IF; + + IF REC.T.X /= IDENT_FLT(6.0) THEN + FAILED("INCORRECT EXPLICIT INITIALIZATION OF REAL"); + END IF; + + IF REC.T.FIRST /= YELLOW THEN + FAILED("INCORRECT EXPLICIT INITIALIZATION OF ENUMERATION"); + END IF; + + FOR I IN 1 .. 3 LOOP + IF REC.U.A(I) /= IDENT_FLT(2.25) THEN + FAILED("INCORRECT EXPLICIT INITIALIZATION OF ARRAY " & + "POSITION " & INTEGER'IMAGE(I)); + END IF; + END LOOP; + + IF REC.L.A /= IDENT_INT(5) THEN + FAILED("INCORRECT EXPLICIT INITIALIZATION OF DISCRIMINANT " & + "- L"); + END IF; + + IF REC.L.I /= IDENT_INT(5) THEN + FAILED("INCORRECT EXPLICIT INITIALIZATION OF INTEGER - L"); + END IF; + + IF NOT IDENT_BOOL(REC.L.BOL) THEN + FAILED("INCORRECT EXPLICIT INITIALIZATION OF BOOLEAN - L"); + END IF; + + IF REC.L.X /= IDENT_FLT(6.0) THEN + FAILED("INCORRECT EXPLICIT INITIALIZATION OF REAL - L"); + END IF; + + IF REC.L.FIRST /= IDENT_ENUM(YELLOW) THEN + FAILED("INCORRECT EXPLICIT INITIALIZATION OF ENUMERATION " & + "- L"); + END IF; + + RESULT; + +END C37009A; diff --git a/gcc-4.9/gcc/testsuite/ada/acats/tests/c3/c37010a.ada b/gcc-4.9/gcc/testsuite/ada/acats/tests/c3/c37010a.ada new file mode 100644 index 000000000..64ba42018 --- /dev/null +++ b/gcc-4.9/gcc/testsuite/ada/acats/tests/c3/c37010a.ada @@ -0,0 +1,140 @@ +-- C37010A.ADA + +-- Grant of Unlimited Rights +-- +-- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687, +-- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained +-- unlimited rights in the software and documentation contained herein. +-- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making +-- this public release, the Government intends to confer upon all +-- recipients unlimited rights equal to those held by the Government. +-- These rights include rights to use, duplicate, release or disclose the +-- released technical data and computer software in whole or in part, in +-- any manner and for any purpose whatsoever, and to have or permit others +-- to do so. +-- +-- DISCLAIMER +-- +-- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR +-- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED +-- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF 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 EXPRESSIONS IN CONSTRAINTS OF COMPONENT DECLARATIONS ARE +-- EVALUATED IN THE ORDER THE COMPONENTS APPEAR. + +-- R.WILLIAMS 8/22/86 + +WITH REPORT; USE REPORT; +PROCEDURE C37010A IS + + TYPE R (D : INTEGER) IS + RECORD + NULL; + END RECORD; + + TYPE ACCR IS ACCESS R; + + TYPE ARR IS ARRAY (POSITIVE RANGE <> ) OF INTEGER; + + TYPE ACCA IS ACCESS ARR; + + BUMP : INTEGER := 0; + + FUNCTION F RETURN INTEGER IS + BEGIN + BUMP := BUMP + 1; + RETURN BUMP; + END; + +BEGIN + TEST ( "C37010A", "CHECK THAT EXPRESSIONS IN CONSTRAINTS OF " & + "COMPONENT DECLARATIONS ARE EVALUATED IN " & + "THE ORDER THE COMPONENTS APPEAR" ); + + DECLARE + + TYPE REC1 IS + RECORD + A1 : R (D => F); + B1 : STRING (1 .. F); + C1 : ACCR (F); + D1 : ACCA (1 .. F); + END RECORD; + + R1 : REC1; + + BEGIN + IF R1.A1.D /= 1 THEN + FAILED ( "INCORRECT VALUE FOR R1.A1.D" ); + END IF; + + IF R1.B1'LAST /= 2 THEN + FAILED ( "INCORRECT VALUE FOR R1.B1'LAST" ); + END IF; + + BEGIN + R1.C1 := NEW R'(D => 3); + EXCEPTION + WHEN OTHERS => + FAILED ( "INCORRECT VALUE FOR R1.C1" ); + END; + + BEGIN + R1.D1 := NEW ARR (1 .. 4); + EXCEPTION + WHEN OTHERS => + FAILED ( "INCORRECT VALUE FOR R1.D1" ); + END; + + END; + + BUMP := 0; + + DECLARE + + TYPE REC2 (I : INTEGER) IS + RECORD + CASE I IS + WHEN 1 => + NULL; + WHEN OTHERS => + A2 : R (D => F); + B2 : ARR (1 .. F); + C2 : ACCR (F); + D2 : ACCA (1 .. F); + END CASE; + END RECORD; + + R2 : REC2 (IDENT_INT (2)); + + BEGIN + + IF R2.A2.D /= 1 THEN + FAILED ( "INCORRECT VALUE FOR R2.A2.D" ); + END IF; + + IF R2.B2'LAST /= 2 THEN + FAILED ( "INCORRECT VALUE FOR R2.B2'LAST" ); + END IF; + + BEGIN + R2.C2 := NEW R (D => 3); + EXCEPTION + WHEN OTHERS => + FAILED ( "INCORRECT VALUE FOR R2.C2" ); + END; + + BEGIN + R2.D2 := NEW ARR (1 .. 4); + EXCEPTION + WHEN OTHERS => + FAILED ( "INCORRECT VALUE FOR R2.D2" ); + END; + + END; + + RESULT; +END C37010A; diff --git a/gcc-4.9/gcc/testsuite/ada/acats/tests/c3/c37010b.ada b/gcc-4.9/gcc/testsuite/ada/acats/tests/c3/c37010b.ada new file mode 100644 index 000000000..aa94b2dec --- /dev/null +++ b/gcc-4.9/gcc/testsuite/ada/acats/tests/c3/c37010b.ada @@ -0,0 +1,164 @@ +-- C37010B.ADA + +-- Grant of Unlimited Rights +-- +-- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687, +-- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained +-- unlimited rights in the software and documentation contained herein. +-- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making +-- this public release, the Government intends to confer upon all +-- recipients unlimited rights equal to those held by the Government. +-- These rights include rights to use, duplicate, release or disclose the +-- released technical data and computer software in whole or in part, in +-- any manner and for any purpose whatsoever, and to have or permit others +-- to do so. +-- +-- DISCLAIMER +-- +-- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR +-- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED +-- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF 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 EXPRESSIONS IN AN INDEX CONSTRAINT OR DISCRIMINANT +-- CONSTRAINT ARE EVALUATED WHEN THE COMPONENT DECLARATION IS +-- ELABORATED EVEN IF SOME BOUNDS OR DISCRIMINANTS ARE GIVEN BY +-- A DISCRIMINANT OF AN ENCLOSING RECORD TYPE. + +-- R.WILLIAMS 8/22/86 + +WITH REPORT; USE REPORT; +PROCEDURE C37010B IS + + INIT :INTEGER := IDENT_INT (5); + + TYPE R (D1, D2 : INTEGER) IS + RECORD + NULL; + END RECORD; + + TYPE ACCR IS ACCESS R; + + TYPE ARR IS ARRAY (INTEGER RANGE <> ) OF INTEGER; + + TYPE ACCA IS ACCESS ARR; + + FUNCTION RESET (N : INTEGER) RETURN INTEGER IS + BEGIN + INIT := IDENT_INT (N); + RETURN N; + END RESET; + +BEGIN + TEST ( "C37010B", "CHECK THAT EXPRESSIONS IN AN INDEX " & + "CONSTRAINT OR DISCRIMINANT CONSTRAINT " & + "ARE EVALUATED WHEN THE COMPONENT " & + "DECLARATION IS ELABORATED EVEN IF SOME " & + "BOUNDS OR DISCRIMINANTS ARE GIVEN BY " & + "A DISCRIMINANT OF AN ENCLOSING RECORD TYPE" ); + + DECLARE + + TYPE REC1 (D : INTEGER) IS + RECORD + W1 : R (D1 => INIT, D2 => D); + X1 : ARR (INIT .. D); + Y1 : ACCR (D, INIT); + Z1 : ACCA (D .. INIT); + END RECORD; + + INT1 : INTEGER := RESET (10); + + R1 : REC1 (D => 4); + + BEGIN + IF R1.W1.D1 /= 5 THEN + FAILED ( "INCORRECT VALUE FOR R1.W1.D1" ); + END IF; + + IF R1.W1.D2 /= 4 THEN + FAILED ( "INCORRECT VALUE FOR R1.W1.D2" ); + END IF; + + IF R1.X1'FIRST /= 5 THEN + FAILED ( "INCORRECT VALUE FOR R1.X1'FIRST" ); + END IF; + + IF R1.X1'LAST /= 4 THEN + FAILED ( "INCORRECT VALUE FOR R1.X1'LAST" ); + END IF; + + BEGIN + R1.Y1 := NEW R (4, 5); + EXCEPTION + WHEN OTHERS => + FAILED ( "INCORRECT VALUE FOR R1.Y1" ); + END; + + BEGIN + R1.Z1 := NEW ARR (4 .. 5); + EXCEPTION + WHEN OTHERS => + FAILED ( "INCORRECT VALUE FOR R1.Z1" ); + END; + + END; + + DECLARE + + TYPE REC2 (D : INTEGER) IS + RECORD + CASE D IS + WHEN 1 => + NULL; + WHEN 2 => + NULL; + WHEN OTHERS => + W2 : R (D1 => D, D2 => INIT); + X2 : ARR (D .. INIT); + Y2 : ACCR (INIT, D); + Z2 : ACCA (D .. INIT); + END CASE; + END RECORD; + + INT2 : INTEGER := RESET (20); + + R2 : REC2 (D => 6); + + BEGIN + IF R2.W2.D1 /= 6 THEN + FAILED ( "INCORRECT VALUE FOR R2.W2.D1" ); + END IF; + + IF R2.W2.D2 /= 10 THEN + FAILED ( "INCORRECT VALUE FOR R2.W2.D2" ); + END IF; + + IF R2.X2'FIRST /= 6 THEN + FAILED ( "INCORRECT VALUE FOR R2.X2'FIRST" ); + END IF; + + IF R2.X2'LAST /= 10 THEN + FAILED ( "INCORRECT VALUE FOR R2.X2'LAST" ); + END IF; + + BEGIN + R2.Y2 := NEW R (10, 6); + EXCEPTION + WHEN OTHERS => + FAILED ( "INCORRECT VALUE FOR R2.Y2" ); + END; + + BEGIN + R2.Z2 := NEW ARR (6 .. 10); + EXCEPTION + WHEN OTHERS => + FAILED ( "INCORRECT VALUE FOR R2.Z2" ); + END; + + END; + + RESULT; +END C37010B; diff --git a/gcc-4.9/gcc/testsuite/ada/acats/tests/c3/c371001.a b/gcc-4.9/gcc/testsuite/ada/acats/tests/c3/c371001.a new file mode 100644 index 000000000..f6823570b --- /dev/null +++ b/gcc-4.9/gcc/testsuite/ada/acats/tests/c3/c371001.a @@ -0,0 +1,388 @@ +-- C371001.A +-- +-- Grant of Unlimited Rights +-- +-- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687, +-- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained +-- unlimited rights in the software and documentation contained herein. +-- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making +-- this public release, the Government intends to confer upon all +-- recipients unlimited rights equal to those held by the Government. +-- These rights include rights to use, duplicate, release or disclose the +-- released technical data and computer software in whole or in part, in +-- any manner and for any purpose whatsoever, and to have or permit others +-- to do so. +-- +-- DISCLAIMER +-- +-- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR +-- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED +-- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE +-- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE +-- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A +-- PARTICULAR PURPOSE OF SAID MATERIAL. +--* +-- +-- OBJECTIVE: +-- Check that if a discriminant constraint depends on a discriminant, +-- the evaluation of the expressions in the constraint is deferred +-- until an object of the subtype is created. Check for cases of +-- records with private type component. +-- +-- TEST DESCRIPTION: +-- This transition test defines record type and incomplete types with +-- discriminant components which depend on the discriminants. The +-- discriminants are calculated by function calls. The test verifies +-- that Constraint_Error is raised during the object creations when +-- values of discriminants are incompatible with the subtypes. +-- +-- Inspired by C37214A.ADA and C37216A.ADA. +-- +-- +-- CHANGE HISTORY: +-- 11 Apr 96 SAIC Initial version for ACVC 2.1. +-- 06 Oct 96 SAIC Added LM references. Replaced "others exception" +-- with "unexpected exception" +-- +--! + +with Report; + +procedure C371001 is + + subtype Small_Int is Integer range 1..10; + + Func1_Cons : Integer := 0; + + --------------------------------------------------------- + function Func1 return Integer is + begin + Func1_Cons := Func1_Cons + Report.Ident_Int(1); + return Func1_Cons; + end Func1; + + +begin + Report.Test ("C371001", "Check that if a discriminant constraint " & + "depends on a discriminant, the evaluation of the " & + "expressions in the constraint is deferred until " & + "object declarations"); + + --------------------------------------------------------- + -- Constraint checks on an object declaration of a record. + + begin + + declare + + package C371001_0 is + + type PT_W_Disc (D : Small_Int) is private; + type Rec_W_Private (D1 : Integer) is + record + C : PT_W_Disc (D1); + end record; + + type Rec (D3 : Integer) is + record + C1 : Rec_W_Private (D3); + end record; + + private + type PT_W_Disc (D : Small_Int) is + record + Str : String (1 .. D) := (others => '*'); + end record; + + end C371001_0; + + --=====================================================-- + + Obj : C371001_0.Rec(Report.Ident_Int(0)); -- Constraint_Error raised. + + begin + Report.Failed ("Obj - Constraint_Error should be raised"); + if Obj.C1.D1 /= 0 then + Report.Failed ("Obj - Shouldn't get here"); + end if; + + exception + when others => + Report.Failed ("Obj - exception raised too late"); + end; + + exception + when Constraint_Error => -- Exception expected. + null; + when others => + Report.Failed ("Obj - unexpected exception raised"); + end; + + ------------------------------------------------------------------- + -- Constraint checks on an object declaration of an array. + + begin + declare + + package C371001_1 is + + type PT_W_Disc (D : Small_Int) is private; + type Rec_W_Private (D1 : Integer) is + record + C : PT_W_Disc (D1); + end record; + + type Rec_01 (D3 : Integer) is + record + C1 : Rec_W_Private (D3); + end record; + + type Arr is array (1 .. 5) of + Rec_01(Report.Ident_Int(0)); -- No Constraint_Error + -- raised. + private + type PT_W_Disc (D : Small_Int) is + record + Str : String (1 .. D) := (others => '*'); + end record; + + end C371001_1; + + --=====================================================-- + + begin + declare + Obj1 : C371001_1.Arr; -- Constraint_Error raised. + begin + Report.Failed ("Obj1 - Constraint_Error should be raised"); + if Obj1(1).D3 /= 0 then + Report.Failed ("Obj1 - Shouldn't get here"); + end if; + + exception + when others => + Report.Failed ("Obj1 - exception raised too late"); + end; + + exception + when Constraint_Error => -- Exception expected. + null; + when others => + Report.Failed ("Obj1 - unexpected exception raised"); + end; + + exception + when Constraint_Error => + Report.Failed ("Arr - Constraint_Error raised"); + when others => + Report.Failed ("Arr - unexpected exception raised"); + end; + + + ------------------------------------------------------------------- + -- Constraint checks on an object declaration of an access type. + + begin + declare + + package C371001_2 is + + type PT_W_Disc (D : Small_Int) is private; + type Rec_W_Private (D1 : Integer) is + record + C : PT_W_Disc (D1); + end record; + + type Rec_02 (D3 : Integer) is + record + C1 : Rec_W_Private (D3); + end record; + + type Acc_Rec2 is access Rec_02 -- No Constraint_Error + (Report.Ident_Int(11)); -- raised. + + private + type PT_W_Disc (D : Small_Int) is + record + Str : String (1 .. D) := (others => '*'); + end record; + + end C371001_2; + + --=====================================================-- + + begin + declare + Obj2 : C371001_2.Acc_Rec2; -- No Constraint_Error + -- raised. + begin + Obj2 := new C371001_2.Rec_02 (Report.Ident_Int(11)); + -- Constraint_Error raised. + + Report.Failed ("Obj2 - Constraint_Error should be raised"); + if Obj2.D3 /= 1 then + Report.Failed ("Obj2 - Shouldn't get here"); + end if; + + exception + when Constraint_Error => -- Exception expected. + null; + when others => + Report.Failed ("Obj2 - unexpected exception raised in " & + "assignment"); + end; + + exception + when Constraint_Error => + Report.Failed ("Obj2 - Constraint_Error raised in declaration"); + when others => + Report.Failed ("Obj2 - unexpected exception raised in " & + "declaration"); + end; + + exception + when Constraint_Error => + Report.Failed ("Acc_Rec2 - Constraint_Error raised"); + when others => + Report.Failed ("Acc_Rec2 - unexpected exception raised"); + end; + + ------------------------------------------------------------------- + -- Constraint checks on an object declaration of a subtype. + + Func1_Cons := -1; + + begin + declare + + package C371001_3 is + + type PT_W_Disc (D1, D2 : Small_Int) is private; + type Rec_W_Private (D3, D4 : Integer) is + record + C : PT_W_Disc (D3, D4); + end record; + + type Rec_03 (D5 : Integer) is + record + C1 : Rec_W_Private (D5, Func1); -- Func1 evaluated, + end record; -- value 0. + + subtype Subtype_Rec is Rec_03(1); -- No Constraint_Error + -- raised. + private + type PT_W_Disc (D1, D2 : Small_Int) is + record + Str1 : String (1 .. D1) := (others => '*'); + Str2 : String (1 .. D2) := (others => '*'); + end record; + + end C371001_3; + + --=====================================================-- + + begin + declare + Obj3 : C371001_3.Subtype_Rec; -- Constraint_Error raised. + begin + Report.Failed ("Obj3 - Constraint_Error should be raised"); + if Obj3.D5 /= 1 then + Report.Failed ("Obj3 - Shouldn't get here"); + end if; + + exception + when others => + Report.Failed ("Obj3 - exception raised too late"); + end; + + exception + when Constraint_Error => -- Exception expected. + null; + when others => + Report.Failed ("Obj3 - unexpected exception raised"); + end; + + exception + when Constraint_Error => + Report.Failed ("Subtype_Rec - Constraint_Error raised"); + when others => + Report.Failed ("Subtype_Rec - unexpected exception raised"); + end; + + ------------------------------------------------------------------- + -- Constraint checks on an object declaration of an incomplete type. + + Func1_Cons := 10; + + begin + declare + + package C371001_4 is + + type Rec_04 (D3 : Integer); + type PT_W_Disc (D : Small_Int) is private; + type Rec_W_Private (D1, D2 : Small_Int) is + record + C : PT_W_Disc (D2); + end record; + + type Rec_04 (D3 : Integer) is + record + C1 : Rec_W_Private (D3, Func1); -- Func1 evaluated + end record; -- value 11. + + type Acc_Rec4 is access Rec_04 (1); -- No Constraint_Error + -- raised. + private + type PT_W_Disc (D : Small_Int) is + record + Str : String (1 .. D) := (others => '*'); + end record; + + end C371001_4; + + --=====================================================-- + + begin + declare + Obj4 : C371001_4.Acc_Rec4; -- No Constraint_Error + -- raised. + begin + Obj4 := new C371001_4.Rec_04 (1); -- Constraint_Error raised. + + Report.Failed ("Obj4 - Constraint_Error should be raised"); + if Obj4.D3 /= 1 then + Report.Failed ("Obj4 - Shouldn't get here"); + end if; + + exception + when Constraint_Error => -- Exception expected. + null; + when others => + Report.Failed ("Obj4 - unexpected exception raised in " & + "assignment"); + end; + + exception + when Constraint_Error => + Report.Failed ("Obj4 - Constraint_Error raised in declaration"); + when others => + Report.Failed ("Obj4 - unexpected exception raised in " & + "declaration"); + end; + + exception + when Constraint_Error => + Report.Failed ("Acc_Rec4 - Constraint_Error raised"); + when others => + Report.Failed ("Acc_Rec4 - unexpected exception raised"); + end; + + Report.Result; + +exception + when others => + Report.Failed ("Discriminant value checked too soon"); + Report.Result; + +end C371001; diff --git a/gcc-4.9/gcc/testsuite/ada/acats/tests/c3/c371002.a b/gcc-4.9/gcc/testsuite/ada/acats/tests/c3/c371002.a new file mode 100644 index 000000000..ea532550c --- /dev/null +++ b/gcc-4.9/gcc/testsuite/ada/acats/tests/c3/c371002.a @@ -0,0 +1,364 @@ +-- C371002.A +-- +-- Grant of Unlimited Rights +-- +-- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687, +-- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained +-- unlimited rights in the software and documentation contained herein. +-- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making +-- this public release, the Government intends to confer upon all +-- recipients unlimited rights equal to those held by the Government. +-- These rights include rights to use, duplicate, release or disclose the +-- released technical data and computer software in whole or in part, in +-- any manner and for any purpose whatsoever, and to have or permit others +-- to do so. +-- +-- DISCLAIMER +-- +-- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR +-- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED +-- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE +-- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE +-- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A +-- PARTICULAR PURPOSE OF SAID MATERIAL. +--* +-- +-- OBJECTIVE: +-- Check that if a discriminant constraint depends on a discriminant, +-- the evaluation of the expressions in the constraint is deferred until +-- an object of the subtype is created. Check for cases of records. +-- +-- TEST DESCRIPTION: +-- This transition test defines record types with discriminant components +-- which depend on the discriminants. The discriminants are calculated +-- by function calls. The test verifies that Constraint_Error is raised +-- during the object creations when values of discriminants are +-- incompatible with the subtypes. +-- +-- Inspired by C37213A.ADA, C37213C.ADA, C37215A.ADA and C37215C.ADA. +-- +-- +-- CHANGE HISTORY: +-- 05 Apr 96 SAIC Initial version for ACVC 2.1. +-- +--! + +with Report; + +procedure C371002 is + + subtype Small_Int is Integer range 1..10; + + type Rec_W_Disc (Disc1, Disc2 : Small_Int) is + record + Str1 : String (1 .. Disc1) := (others => '*'); + Str2 : String (1 .. Disc2) := (others => '*'); + end record; + + type My_Array is array (Small_Int range <>) of Integer; + + Func1_Cons : Integer := 0; + + --------------------------------------------------------- + function Chk (Cons : Integer; + Value : Integer; + Message : String) return Boolean is + begin + if Cons /= Value then + Report.Failed (Message & ": Func1_Cons is " & + Integer'Image(Func1_Cons)); + end if; + return True; + end Chk; + + --------------------------------------------------------- + function Func1 return Integer is + begin + Func1_Cons := Func1_Cons + Report.Ident_Int(1); + return Func1_Cons; + end Func1; + +begin + Report.Test ("C371002", "Check that if a discriminant constraint " & + "depends on a discriminant, the evaluation of the " & + "expressions in the constraint is deferred until " & + "object declarations"); + + --------------------------------------------------------- + declare + type Rec1 (D3 : Integer) is + record + C1 : Rec_W_Disc (D3, Func1); -- Func1 evaluated, value 1. + end record; + + Chk1 : Boolean := Chk (Func1_Cons, 1, + "Func1 not evaluated for Rec1"); + + Obj1 : Rec1 (1); -- Func1 not evaluated again. + Obj2 : Rec1 (2); -- Func1 not evaluated again. + + Chk2 : Boolean := Chk (Func1_Cons, 1, + "Func1 evaluated too many times"); + begin + if Obj1 /= (D3 => 1, + C1 => (Disc1 => 1, + Disc2 => 1, + Str1 => (others => '*'), + Str2 => (others => '*'))) or + Obj2 /= (D3 => 2, + C1 => (Disc1 => 2, + Disc2 => 1, + Str1 => (others => '*'), + Str2 => (others => '*'))) then + Report.Failed ("Obj1 & Obj2 - Discriminant values not correct"); + end if; + end; + + --------------------------------------------------------- + Func1_Cons := -11; + + declare + type Rec_Of_Rec_01 (D3 : Integer) is + record + C1 : Rec_W_Disc (D3, Func1); -- Func1 evaluated, value -10. + end record; -- Constraint_Error not raised. + + type Rec_Of_MyArr_01 (D3 : Integer) is + record + C1 : My_Array (Func1 .. D3); -- Func1 evaluated, value -9. + end record; -- Constraint_Error not raised. + + type Rec_Of_Rec_02 (D3 : Integer) is + record + C1 : Rec_W_Disc (D3, 1); + end record; + + type Rec_Of_MyArr_02 (D3 : Integer) is + record + C1 : My_Array (D3 .. 1); + end record; + + begin + + --------------------------------------------------------- + begin + declare + Obj3 : Rec_Of_Rec_01(1); -- Constraint_Error raised. + begin + Report.Failed ("Obj3 - Constraint_Error should be raised"); + if Obj3 /= (1, (1, 1, others => (others => '*'))) then + Report.Comment ("Obj3 - Shouldn't get here"); + end if; + end; + + exception + when Constraint_Error => -- Exception expected. + null; + when others => + Report.Failed ("Obj3 - others exception raised"); + end; + + --------------------------------------------------------- + begin + declare + subtype Subtype_Rec is Rec_Of_Rec_01(1); + -- No Constraint_Error raised. + begin + declare + Obj4 : Subtype_Rec; -- Constraint_Error raised. + begin + Report.Failed ("Obj4 - Constraint_Error should be raised"); + if Obj4 /= (D3 => 1, + C1 => (Disc1 => 1, + Disc2 => 1, + Str1 => (others => '*'), + Str2 => (others => '*'))) then + Report.Comment ("Obj4 - Shouldn't get here"); + end if; + end; + + exception + when Constraint_Error => -- Exception expected. + null; + when others => + Report.Failed ("Obj4 - others exception raised"); + end; + + exception + when Constraint_Error => + Report.Failed ("Subtype_Rec - Constraint_Error raised"); + when others => + Report.Failed ("Subtype_Rec - others exception raised"); + end; + + --------------------------------------------------------- + begin + declare + type Arr is array (1..5) -- No Constraint_Error raised. + of Rec_Of_Rec_01(1); + + begin + declare + Obj5 : Arr; -- Constraint_Error raised. + begin + Report.Failed ("Obj5 - Constraint_Error should be raised"); + if Obj5 /= (1..5 => (1, (1, 1, others => (others => '*')))) then + Report.Comment ("Obj5 - Shouldn't get here"); + end if; + end; + + exception + when Constraint_Error => -- Exception expected. + null; + when others => + Report.Failed ("Obj5 - others exception raised"); + end; + + exception + when Constraint_Error => + Report.Failed ("Arr - Constraint_Error raised"); + when others => + Report.Failed ("Arr - others exception raised"); + end; + + --------------------------------------------------------- + begin + declare + type Rec_Of_Rec_Of_MyArr is + record + C1 : Rec_Of_MyArr_01(1); -- No Constraint_Error raised. + end record; + begin + declare + Obj6 : Rec_Of_Rec_Of_MyArr; -- Constraint_Error raised. + begin + Report.Failed ("Obj6 - Constraint_Error should be raised"); + if Obj6 /= (C1 => (1, (1, 1))) then + Report.Comment ("Obj6 - Shouldn't get here"); + end if; + end; + + exception + when Constraint_Error => -- Exception expected. + null; + when others => + Report.Failed ("Obj6 - others exception raised"); + end; + + exception + when Constraint_Error => + Report.Failed ("Rec_Of_Rec_Of_MyArr - Constraint_Error raised"); + when others => + Report.Failed ("Rec_Of_Rec_Of_MyArr - others exception raised"); + end; + + --------------------------------------------------------- + begin + declare + type New_Rec is + new Rec_Of_MyArr_01(1); -- No Constraint_Error raised. + + begin + declare + Obj7 : New_Rec; -- Constraint_Error raised. + begin + Report.Failed ("Obj7 - Constraint_Error should be raised"); + if Obj7 /= (1, (1, 1)) then + Report.Comment ("Obj7 - Shouldn't get here"); + end if; + end; + + exception + when Constraint_Error => -- Exception expected. + null; + when others => + Report.Failed ("Obj7 - others exception raised"); + end; + + exception + when Constraint_Error => + Report.Failed ("New_Rec - Constraint_Error raised"); + when others => + Report.Failed ("New_Rec - others exception raised"); + end; + + --------------------------------------------------------- + begin + declare + type Acc_Rec is + access Rec_Of_Rec_02 (Report.Ident_Int(0)); + -- No Constraint_Error raised. + begin + declare + Obj8 : Acc_Rec; -- No Constraint_Error raised. + + begin + Obj8 := new Rec_Of_Rec_02 (Report.Ident_Int(0)); + -- Constraint_Error raised. + + Report.Failed ("Obj8 - Constraint_Error should be raised"); + if Obj8.all /= (D3 => 1, + C1 => (Disc1 => 1, + Disc2 => 1, + Str1 => (others => '*'), + Str2 => (others => '*'))) then + Report.Comment ("Obj8 - Shouldn't get here"); + end if; + end; + + exception + when Constraint_Error => -- Exception expected. + null; + when others => + Report.Failed ("Obj8 - others exception raised"); + end; + + exception + when Constraint_Error => + Report.Failed ("Acc_Rec - Constraint_Error raised"); + when others => + Report.Failed ("Acc_Rec - others exception raised"); + end; + + --------------------------------------------------------- + begin + declare + type Acc_Rec_MyArr is access + Rec_Of_MyArr_02; -- No Constraint_Error + -- raised for either + Obj9 : Acc_Rec_MyArr; -- declaration. + + begin + Obj9 := new Rec_Of_MyArr_02 (Report.Ident_Int(0)); + -- Constraint_Error raised. + + Report.Failed ("Obj9 - Constraint_Error should be raised"); + + if Obj9.all /= (1, (1, 1)) then + Report.Comment ("Obj9 - Shouldn't get here"); + end if; + + exception + when Constraint_Error => -- Exception expected. + null; + when others => + Report.Failed ("Obj9 - others exception raised"); + end; + + exception + when Constraint_Error => + Report.Failed ("Acc_Rec_MyArr - Constraint_Error raised"); + when others => + Report.Failed ("Acc_Rec_MyArr - others exception raised"); + end; + + end; + + Report.Result; + +exception + when others => + Report.Failed ("Discriminant value checked too soon"); + Report.Result; + +end C371002; diff --git a/gcc-4.9/gcc/testsuite/ada/acats/tests/c3/c371003.a b/gcc-4.9/gcc/testsuite/ada/acats/tests/c3/c371003.a new file mode 100644 index 000000000..c4a8345f6 --- /dev/null +++ b/gcc-4.9/gcc/testsuite/ada/acats/tests/c3/c371003.a @@ -0,0 +1,474 @@ +-- C371003.A +-- +-- Grant of Unlimited Rights +-- +-- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687, +-- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained +-- unlimited rights in the software and documentation contained herein. +-- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making +-- this public release, the Government intends to confer upon all +-- recipients unlimited rights equal to those held by the Government. +-- These rights include rights to use, duplicate, release or disclose the +-- released technical data and computer software in whole or in part, in +-- any manner and for any purpose whatsoever, and to have or permit others +-- to do so. +-- +-- DISCLAIMER +-- +-- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR +-- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED +-- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE +-- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE +-- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A +-- PARTICULAR PURPOSE OF SAID MATERIAL. +--* +-- +-- OBJECTIVE: +-- Check that if a discriminant constraint depends on a discriminant, +-- the evaluation of the expressions in the constraint is deferred +-- until an object of the subtype is created. Check for cases of +-- records where the component containing the constraint is present +-- in the subtype. +-- +-- TEST DESCRIPTION: +-- This transition test defines record types with discriminant components +-- which depend on the discriminants. The discriminants are calculated +-- by function calls. The test verifies that Constraint_Error is raised +-- during the object creations when values of discriminants are +-- incompatible with the subtypes. Also check for cases, where the +-- component is absent. +-- +-- Inspired by C37213E.ADA, C37213G.ADA, C37215E.ADA, and C37215G.ADA. +-- +-- +-- CHANGE HISTORY: +-- 10 Apr 96 SAIC Initial version for ACVC 2.1. +-- 14 Jul 96 SAIC Modified test description. Added exception handler +-- for VObj_10 assignment. +-- 26 Oct 96 SAIC Added LM references. +-- +--! + +with Report; + +procedure C371003 is + + subtype Small_Int is Integer range 1..10; + + type Rec_W_Disc (Disc1, Disc2 : Small_Int) is + record + Str1 : String (1 .. Disc1) := (others => '*'); + Str2 : String (1 .. Disc2) := (others => '*'); + end record; + + type My_Array is array (Small_Int range <>) of Integer; + + Func1_Cons : Integer := 0; + + --------------------------------------------------------- + function Chk (Cons : Integer; + Value : Integer; + Message : String) return Boolean is + begin + if Cons /= Value then + Report.Failed (Message & ": Func1_Cons is " & + Integer'Image(Func1_Cons)); + end if; + return True; + end Chk; + + --------------------------------------------------------- + function Func1 return Integer is + begin + Func1_Cons := Func1_Cons + Report.Ident_Int(1); + return Func1_Cons; + end Func1; + + +begin + Report.Test ("C371003", "Check that if a discriminant constraint " & + "depends on a discriminant, the evaluation of the " & + "expressions in the constraint is deferred until " & + "object declarations"); + + --------------------------------------------------------- + declare + type VRec_01 (D3 : Integer) is + record + case D3 is + when -5..10 => + C1 : Rec_W_Disc (D3, Func1); -- Func1 evaluated, value 1. + when others => + C2 : Integer := Report.Ident_Int(0); + end case; + end record; + + Chk1 : Boolean := Chk (Func1_Cons, 1, + "Func1 not evaluated for VRec_01"); + + VObj_1 : VRec_01(1); -- Func1 not evaluated again + VObj_2 : VRec_01(2); -- Func1 not evaluated again + + Chk2 : Boolean := Chk (Func1_Cons, 1, + "Func1 evaluated too many times"); + + begin + if VObj_1 /= (D3 => 1, + C1 => (Disc1 => 1, + Disc2 => 1, + Str1 => (others => '*'), + Str2 => (others => '*'))) or + VObj_2 /= (D3 => 2, + C1 => (Disc1 => 2, + Disc2 => 1, + Str1 => (others => '*'), + Str2 => (others => '*'))) then + Report.Failed ("VObj_1 & VObj_2 - Discriminant values not correct"); + end if; + end; + + --------------------------------------------------------- + Func1_Cons := -11; + + declare + type VRec_Of_VRec_01 (D3 : Integer) is + record + case D3 is + when -5..10 => + C1 : Rec_W_Disc (Func1, D3); -- Func1 evaluated, value -10. + when others => -- Constraint_Error not raised. + C2 : Integer := Report.Ident_Int(0); + end case; + end record; + + type VRec_Of_VRec_02 (D3 : Integer) is + record + case D3 is + when -5..10 => + C1 : Rec_W_Disc (1, D3); + when others => + C2 : Integer := Report.Ident_Int(0); + end case; + end record; + + type VRec_Of_MyArr_01 (D3 : Integer) is + record + case D3 is + when -5..10 => + C1 : My_Array (Func1..D3); -- Func1 evaluated, value -9. + when others => -- Constraint_Error not raised. + C2 : Integer := Report.Ident_Int(0); + end case; + end record; + + type VRec_Of_MyArr_02 (D3 : Integer) is + record + case D3 is + when -5..10 => + C1 : My_Array (D3..1); + when others => + C2 : Integer := Report.Ident_Int(0); + end case; + end record; + + begin + + --------------------------------------------------------- + -- Component containing the constraint is present. + begin + declare + VObj_3 : VRec_Of_VRec_01(1); -- Constraint_Error raised. + begin + Report.Failed ("VObj_3 - Constraint_Error should be raised"); + if VObj_3 /= (1, (1, 1, others => (others => '*'))) then + Report.Comment ("VObj_3 - Shouldn't get here"); + end if; + end; + + exception + when Constraint_Error => -- Exception expected. + null; + when others => + Report.Failed ("VObj_3 - unexpected exception raised"); + end; + + --------------------------------------------------------- + -- Component containing the constraint is present. + begin + declare + subtype Subtype_VRec is -- No Constraint_Error raised. + VRec_Of_VRec_01(Report.Ident_Int(1)); + begin + declare + VObj_4 : Subtype_VRec; -- Constraint_Error raised. + begin + Report.Failed ("VObj_4 - Constraint_Error should be raised"); + if VObj_4 /= (D3 => 1, + C1 => (Disc1 => 1, + Disc2 => 1, + Str1 => (others => '*'), + Str2 => (others => '*'))) then + Report.Comment ("VObj_4 - Shouldn't get here"); + end if; + end; + + exception + when Constraint_Error => -- Exception expected. + null; + when others => + Report.Failed ("VObj_4 - unexpected exception raised"); + end; + + exception + when Constraint_Error => + Report.Failed ("Subtype_VRec - Constraint_Error raised"); + when others => + Report.Failed ("Subtype_VRec - unexpected exception raised"); + end; + + --------------------------------------------------------- + -- Component containing the constraint is absent. + begin + declare + type Arr is array (1..5) of + VRec_Of_VRec_01(Report.Ident_Int(-6)); -- No Constraint_Error + VObj_5 : Arr; -- for either declaration. + + begin + if VObj_5 /= (1 .. 5 => (-6, 0)) then + Report.Comment ("VObj_5 - wrong values"); + end if; + end; + + exception + when others => + Report.Failed ("Arr - unexpected exception raised"); + end; + + --------------------------------------------------------- + -- Component containing the constraint is present. + begin + declare + type Rec_Of_Rec_Of_MyArr is + record + C1 : VRec_Of_MyArr_01(1); -- No Constraint_Error raised. + end record; + begin + declare + Obj_6 : Rec_Of_Rec_Of_MyArr; -- Constraint_Error raised. + begin + Report.Failed ("Obj_6 - Constraint_Error should be raised"); + if Obj_6 /= (C1 => (1, (1, 1))) then + Report.Comment ("Obj_6 - Shouldn't get here"); + end if; + end; + + exception + when Constraint_Error => -- Exception expected. + null; + when others => + Report.Failed ("Obj_6 - unexpected exception raised"); + end; + + exception + when Constraint_Error => + Report.Failed ("Rec_Of_Rec_Of_MyArr - Constraint_Error raised"); + when others => + Report.Failed ("Rec_Of_Rec_Of_MyArr - unexpected exception " & + "raised"); + end; + + --------------------------------------------------------- + -- Component containing the constraint is absent. + begin + declare + type New_VRec_Arr is + new VRec_Of_MyArr_01(11); -- No Constraint_Error raised + Obj_7 : New_VRec_Arr; -- for either declaration. + + begin + if Obj_7 /= (11, 0) then + Report.Failed ("Obj_7 - value incorrect"); + end if; + end; + + exception + when others => + Report.Failed ("New_VRec_Arr - unexpected exception raised"); + end; + + --------------------------------------------------------- + -- Component containing the constraint is present. + begin + declare + type New_VRec is new + VRec_Of_VRec_02(Report.Ident_Int(0)); -- No Constraint_Error + -- raised. + begin + declare + VObj_8 : New_VRec; -- Constraint_Error raised. + begin + Report.Failed ("VObj_8 - Constraint_Error should be raised"); + if VObj_8 /= (1, (1, 1, others => (others => '*'))) then + Report.Comment ("VObj_8 - Shouldn't get here"); + end if; + end; + + exception + when Constraint_Error => -- Exception expected. + null; + when others => + Report.Failed ("VObj_8 - unexpected exception raised"); + end; + + exception + when Constraint_Error => + Report.Failed ("New_VRec - Constraint_Error raised"); + when others => + Report.Failed ("New_VRec - unexpected exception raised"); + end; + + --------------------------------------------------------- + -- Component containing the constraint is absent. + begin + declare + subtype Sub_VRec is + VRec_Of_VRec_02(Report.Ident_Int(11)); -- No Constraint_Error + VObj_9 : Sub_VRec; -- raised for either + -- declaration. + begin + if VObj_9 /= (11, 0) then + Report.Comment ("VObj_9 - wrong values"); + end if; + end; + + exception + when others => + Report.Failed ("Sub_VRec - unexpected exception raised"); + end; + + --------------------------------------------------------- + -- Component containing the constraint is present. + begin + declare + type Acc_VRec_01 is access + VRec_Of_VRec_02(Report.Ident_Int(0)); -- No Constraint_Error + -- raised. + begin + declare + VObj_10 : Acc_VRec_01; -- No Constraint_Error + -- raised. + begin + VObj_10 := new VRec_Of_VRec_02 + (Report.Ident_Int(0)); -- Constraint_Error + -- raised. + Report.Failed ("VObj_10 - Constraint_Error should be raised"); + if VObj_10.all /= (1, (1, 1, others => (others => '*'))) then + Report.Comment ("VObj_10 - Shouldn't get here"); + end if; + + exception + when Constraint_Error => -- Exception expected. + null; + when others => + Report.Failed ("VObj_10 - unexpected exception raised"); + end; + + exception + when Constraint_Error => + Report.Failed ("VObj_10 - Constraint_Error exception raised"); + when others => + Report.Failed ("VObj_10 - unexpected exception raised at " & + "declaration"); + end; + + exception + when Constraint_Error => + Report.Failed ("Acc_VRec_01 - Constraint_Error raised"); + when others => + Report.Failed ("Acc_VRec_01 - unexpected exception raised"); + end; + + --------------------------------------------------------- + -- Component containing the constraint is absent. + begin + declare + type Acc_VRec_02 is access + VRec_Of_VRec_02(11); -- No Constraint_Error + -- raised for either + VObj_11 : Acc_VRec_02; -- declaration. + + begin + VObj_11 := new VRec_Of_VRec_02(11); + if VObj_11.all /= (11, 0) then + Report.Comment ("VObj_11 - wrong values"); + end if; + end; + + exception + when others => + Report.Failed ("Acc_VRec_02 - unexpected exception raised"); + end; + + --------------------------------------------------------- + -- Component containing the constraint is present. + begin + declare + type Acc_VRec_03 is access + VRec_Of_MyArr_02; -- No Constraint_Error + -- raised for either + VObj_12 : Acc_VRec_03; -- declaration. + begin + VObj_12 := new VRec_Of_MyArr_02 + (Report.Ident_Int(0)); -- Constraint_Error raised. + + Report.Failed ("VObj_12 - Constraint_Error should be raised"); + if VObj_12.all /= (1, (1, 1)) then + Report.Comment ("VObj_12 - Shouldn't get here"); + end if; + + exception + when Constraint_Error => -- Exception expected. + null; + when others => + Report.Failed ("VObj_12 - unexpected exception raised"); + end; + + exception + when Constraint_Error => + Report.Failed ("Acc_VRec_03 - Constraint_Error raised"); + when others => + Report.Failed ("Acc_VRec_03 - unexpected exception raised"); + end; + + --------------------------------------------------------- + -- Component containing the constraint is absent. + begin + declare + type Acc_VRec_04 is access + VRec_Of_MyArr_02(11); -- No Constraint_Error + -- raised for either + VObj_13 : Acc_VRec_04; -- declaration. + + begin + VObj_13 := new VRec_Of_MyArr_02(11); + if VObj_13.all /= (11, 0) then + Report.Comment ("VObj_13 - wrong values"); + end if; + end; + + exception + when others => + Report.Failed ("Acc_VRec_04 - unexpected exception raised"); + end; + + end; + + Report.Result; + +exception + when others => + Report.Failed ("Discriminant value checked too soon"); + Report.Result; + +end C371003; diff --git a/gcc-4.9/gcc/testsuite/ada/acats/tests/c3/c37102b.ada b/gcc-4.9/gcc/testsuite/ada/acats/tests/c3/c37102b.ada new file mode 100644 index 000000000..13c4e5c9c --- /dev/null +++ b/gcc-4.9/gcc/testsuite/ada/acats/tests/c3/c37102b.ada @@ -0,0 +1,109 @@ +-- C37102B.ADA + +-- Grant of Unlimited Rights +-- +-- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687, +-- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained +-- unlimited rights in the software and documentation contained herein. +-- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making +-- this public release, the Government intends to confer upon all +-- recipients unlimited rights equal to those held by the Government. +-- These rights include rights to use, duplicate, release or disclose the +-- released technical data and computer software in whole or in part, in +-- any manner and for any purpose whatsoever, and to have or permit others +-- to do so. +-- +-- DISCLAIMER +-- +-- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR +-- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED +-- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE +-- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE +-- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A +-- PARTICULAR PURPOSE OF SAID MATERIAL. +--* +-- CHECK THAT, FOR A RECORD TYPE, THE IDENTIFIER FOR A DISCRIMINANT +-- CAN BE USED AS A SELECTED COMPONENT IN AN INDEX OR DISCRIMINANT +-- CONSTRAINT, AS THE NAME OF A DISCRIMINANT IN A DISCRIMINANT +-- SPECIFICATION, AND AS THE PARAMETER NAME IN A FUNCTION CALL IN A +-- DISCRIMINANT OR INDEX CONSTRAINT. + +-- R.WILLIAMS 8/25/86 + +WITH REPORT; USE REPORT; +PROCEDURE C37102B IS + +BEGIN + TEST ( "C37102B", "CHECK THAT, FOR A RECORD TYPE, THE " & + "IDENTIFIER FOR A DISCRIMINANT CAN BE USED " & + "AS A SELECTED COMPONENT IN AN INDEX OR " & + "DISCRIMINANT CONSTRAINT, AS THE NAME OF A " & + "DISCRIMINANT IN A DISCRIMINANT " & + "SPECIFICATION, AND AS THE PARAMETER NAME " & + "IN A FUNCTION CALL IN A DISCRIMINANT OR " & + "INDEX CONSTRAINT" ); + + DECLARE + + FUNCTION F (D : INTEGER) RETURN INTEGER IS + BEGIN + RETURN IDENT_INT (D); + END F; + + PACKAGE P IS + + TYPE D IS NEW INTEGER; + + TYPE REC1 IS + RECORD + D : INTEGER := IDENT_INT (1); + END RECORD; + + G : REC1; + + TYPE REC2 (D : INTEGER := 3) IS + RECORD + NULL; + END RECORD; + + H : REC2 (IDENT_INT (5)); + + TYPE ARR IS ARRAY (INTEGER RANGE <>) OF INTEGER; + + TYPE Q (D : INTEGER := 0) IS + RECORD + J : REC2 (D => H.D); + K : ARR (G.D .. F (D => 5)); + L : REC2 (F (D => 4)); + END RECORD; + + END P; + + USE P; + + BEGIN + DECLARE + R : Q; + + BEGIN + IF R.J.D /= 5 THEN + FAILED ( "INCORRECT VALUE FOR R.J" ); + END IF; + + IF R.K'FIRST /= 1 THEN + FAILED ( "INCORRECT VALUE FOR R.K'FIRST" ); + END IF; + + IF R.K'LAST /= 5 THEN + FAILED ( "INCORRECT VALUE FOR R.K'LAST" ); + END IF; + + IF R.L.D /= 4 THEN + FAILED ( "INCORRECT VALUE FOR R.L" ); + END IF; + END; + + END; + + RESULT; +END C37102B; diff --git a/gcc-4.9/gcc/testsuite/ada/acats/tests/c3/c37103a.ada b/gcc-4.9/gcc/testsuite/ada/acats/tests/c3/c37103a.ada new file mode 100644 index 000000000..10878357f --- /dev/null +++ b/gcc-4.9/gcc/testsuite/ada/acats/tests/c3/c37103a.ada @@ -0,0 +1,83 @@ +-- C37103A.ADA + +-- Grant of Unlimited Rights +-- +-- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687, +-- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained +-- unlimited rights in the software and documentation contained herein. +-- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making +-- this public release, the Government intends to confer upon all +-- recipients unlimited rights equal to those held by the Government. +-- These rights include rights to use, duplicate, release or disclose the +-- released technical data and computer software in whole or in part, in +-- any manner and for any purpose whatsoever, and to have or permit others +-- to do so. +-- +-- DISCLAIMER +-- +-- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR +-- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED +-- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF 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 DISCRIMINANTS MAY BE BOOLEAN, CHARACTER, USER_ENUM, +-- INTEGER, DERIVED CHARACTER, DERIVED USER_ENUM, DERIVED INTEGER, +-- AND DERIVED DERIVED USER_ENUM. + +-- DAT 5/18/81 +-- SPS 10/25/82 + +WITH REPORT; USE REPORT; + +PROCEDURE C37103A IS +BEGIN + TEST ("C37103A", "MANY DIFFERENT DISCRIMINANT TYPES"); + DECLARE + PACKAGE P1 IS + TYPE ENUM IS (A, Z, Q, 'W', 'A'); + END P1; + + PACKAGE P2 IS + TYPE E2 IS NEW P1.ENUM; + END P2; + + PACKAGE P3 IS + TYPE E3 IS NEW P2.E2; + END P3; + + USE P1, P2, P3; + TYPE INT IS NEW INTEGER RANGE -3 .. 7; + TYPE CHAR IS NEW CHARACTER; + TYPE R1 (D : ENUM) IS RECORD NULL; END RECORD; + TYPE R2 (D : INTEGER) IS RECORD NULL; END RECORD; + TYPE R3 (D : BOOLEAN) IS RECORD NULL; END RECORD; + TYPE R4 (D : CHARACTER) IS RECORD NULL; END RECORD; + TYPE R5 (D : CHAR) IS RECORD NULL; END RECORD; + TYPE R6 (D : E2) IS RECORD NULL; END RECORD; + TYPE R7 (D : E3) IS RECORD NULL; END RECORD; + TYPE R8 (D : INT) IS RECORD NULL; END RECORD; + O1 : R1(A) := (D => A); + O2 : R2(3) := (D => 3); + O3 : R3(TRUE) := (D => TRUE); + O4 : R4(ASCII.NUL) := (D => ASCII.NUL); + O5 : R5('A') := (D => 'A'); + O6 : R6('A') := (D => 'A'); + O7 : R7(A) := (D => A); + O8 : R8(2) := (D => 2); + BEGIN + IF O1.D /= A + OR O2.D /= 3 + OR NOT O3.D + OR O4.D IN 'A' .. 'Z' + OR O5.D /= 'A' + OR O6.D /= 'A' + OR O7.D /= A + OR O8.D /= 2 + THEN FAILED ("WRONG DISCRIMINANT VALUE"); + END IF; + END; + + RESULT; +END C37103A; diff --git a/gcc-4.9/gcc/testsuite/ada/acats/tests/c3/c37105a.ada b/gcc-4.9/gcc/testsuite/ada/acats/tests/c3/c37105a.ada new file mode 100644 index 000000000..b8f836e73 --- /dev/null +++ b/gcc-4.9/gcc/testsuite/ada/acats/tests/c3/c37105a.ada @@ -0,0 +1,55 @@ +-- C37105A.ADA + +-- Grant of Unlimited Rights +-- +-- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687, +-- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained +-- unlimited rights in the software and documentation contained herein. +-- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making +-- this public release, the Government intends to confer upon all +-- recipients unlimited rights equal to those held by the Government. +-- These rights include rights to use, duplicate, release or disclose the +-- released technical data and computer software in whole or in part, in +-- any manner and for any purpose whatsoever, and to have or permit others +-- to do so. +-- +-- DISCLAIMER +-- +-- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR +-- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED +-- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF 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 RECORDS WITH ONLY DISCRIMINANTS ARE OK. + +-- DAT 5/18/81 +-- JWC 6/28/85 RENAMED TO -AB + +WITH REPORT; USE REPORT; + +PROCEDURE C37105A IS +BEGIN + TEST ("C37105A", "RECORDS WITH ONLY DISCRIMINANTS"); + + DECLARE + TYPE R1 (D : BOOLEAN) IS RECORD + NULL; END RECORD; + TYPE R2 (D, E : BOOLEAN) IS RECORD + NULL; END RECORD; + TYPE R3 (A,B,C,D : INTEGER; W,X,Y,Z : CHARACTER) IS + RECORD NULL; END RECORD; + OBJ1 : R1 (IDENT_BOOL(TRUE)); + OBJ2 : R2 (IDENT_BOOL(FALSE), IDENT_BOOL(TRUE)); + OBJ3 : R3 (1,2,3,4,'A','B','C',IDENT_CHAR('D')); + BEGIN + IF OBJ1 = (D => (FALSE)) + OR OBJ2 /= (FALSE, (TRUE)) + OR OBJ3 /= (1,2,3,4,'A','B','C',('D')) + THEN FAILED ("DISCRIMINANT-ONLY RECORDS DON'T WORK"); + END IF; + END; + + RESULT; +END C37105A; diff --git a/gcc-4.9/gcc/testsuite/ada/acats/tests/c3/c37107a.ada b/gcc-4.9/gcc/testsuite/ada/acats/tests/c3/c37107a.ada new file mode 100644 index 000000000..a007f7c31 --- /dev/null +++ b/gcc-4.9/gcc/testsuite/ada/acats/tests/c3/c37107a.ada @@ -0,0 +1,154 @@ +-- C37107A.ADA + +-- Grant of Unlimited Rights +-- +-- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687, +-- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained +-- unlimited rights in the software and documentation contained herein. +-- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making +-- this public release, the Government intends to confer upon all +-- recipients unlimited rights equal to those held by the Government. +-- These rights include rights to use, duplicate, release or disclose the +-- released technical data and computer software in whole or in part, in +-- any manner and for any purpose whatsoever, and to have or permit others +-- to do so. +-- +-- DISCLAIMER +-- +-- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR +-- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED +-- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF 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 DEFAULT DISCRIMINANT EXPRESSION NEED NOT BE STATIC AND +-- IS EVALUATED ONLY WHEN NEEDED. + +-- R.WILLIAMS 8/25/86 +-- GMT 6/29/87 ADDED INTEGER ARGUMENT TO THE FUNCTION F. + + +WITH REPORT; USE REPORT; +PROCEDURE C37107A IS + + FUNCTION F ( B : BOOLEAN; + I : INTEGER ) RETURN INTEGER IS + BEGIN + IF NOT B THEN + FAILED ( "DEFAULT DISCRIMINANT EVALUATED " & + "UNNECESSARILY - " & + INTEGER'IMAGE(I) ); + END IF; + + RETURN IDENT_INT (1); + END F; + +BEGIN + TEST ( "C37107A", "CHECK THAT A DEFAULT DISCRIMINANT " & + "EXPRESSION NEED NOT BE STATIC AND IS " & + "EVALUATED ONLY WHEN NEEDED" ); + + DECLARE + TYPE REC1 ( D : INTEGER := F (TRUE,1) ) IS + RECORD + NULL; + END RECORD; + + R1 : REC1; + + TYPE REC2 ( D : INTEGER := F (FALSE,2) ) IS + RECORD + NULL; + END RECORD; + + R2 : REC2 (D => 0); + + BEGIN + IF R1.D /= 1 THEN + FAILED ( "INCORRECT VALUE FOR R1.D" ); + END IF; + + IF R2.D /= 0 THEN + FAILED ( "INCORRECT VALUE FOR R2.D" ); + END IF; + END; + + DECLARE + + PACKAGE PRIV IS + TYPE REC3 ( D : INTEGER := F (TRUE,3) ) IS PRIVATE; + TYPE REC4 ( D : INTEGER := F (FALSE,4) ) IS PRIVATE; + + PRIVATE + TYPE REC3 ( D : INTEGER := F (TRUE,3) ) IS + RECORD + NULL; + END RECORD; + + TYPE REC4 ( D : INTEGER := F (FALSE,4) ) IS + RECORD + NULL; + END RECORD; + END PRIV; + + USE PRIV; + + BEGIN + DECLARE + R3 : REC3; + R4 : REC4 (D => 0); + + BEGIN + IF R3.D /= 1 THEN + FAILED ( "INCORRECT VALUE FOR R3.D" ); + END IF; + + IF R4.D /= 0 THEN + FAILED ( "INCORRECT VALUE FOR R4.D" ); + END IF; + END; + + END; + + DECLARE + + PACKAGE LPRIV IS + TYPE REC5 + ( D : INTEGER := F (TRUE,5) ) IS LIMITED PRIVATE; + TYPE REC6 + ( D : INTEGER := F (FALSE,6) ) IS LIMITED PRIVATE; + + PRIVATE + TYPE REC5 ( D : INTEGER := F (TRUE,5) ) IS + RECORD + NULL; + END RECORD; + + TYPE REC6 ( D : INTEGER := F (FALSE,6) ) IS + RECORD + NULL; + END RECORD; + END LPRIV; + + USE LPRIV; + + BEGIN + DECLARE + R5 : REC5; + R6 : REC6 (D => 0); + + BEGIN + IF R5.D /= 1 THEN + FAILED ( "INCORRECT VALUE FOR R5.D" ); + END IF; + + IF R6.D /= 0 THEN + FAILED ( "INCORRECT VALUE FOR R6.D" ); + END IF; + END; + + END; + + RESULT; +END C37107A; diff --git a/gcc-4.9/gcc/testsuite/ada/acats/tests/c3/c37108b.ada b/gcc-4.9/gcc/testsuite/ada/acats/tests/c3/c37108b.ada new file mode 100644 index 000000000..9d71e9a72 --- /dev/null +++ b/gcc-4.9/gcc/testsuite/ada/acats/tests/c3/c37108b.ada @@ -0,0 +1,247 @@ +-- C37108B.ADA + +-- Grant of Unlimited Rights +-- +-- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687, +-- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained +-- unlimited rights in the software and documentation contained herein. +-- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making +-- this public release, the Government intends to confer upon all +-- recipients unlimited rights equal to those held by the Government. +-- These rights include rights to use, duplicate, release or disclose the +-- released technical data and computer software in whole or in part, in +-- any manner and for any purpose whatsoever, and to have or permit others +-- to do so. +-- +-- DISCLAIMER +-- +-- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR +-- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED +-- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE +-- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE +-- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A +-- PARTICULAR PURPOSE OF SAID MATERIAL. +--* +-- CHECK THAT CONSTRAINT_ERROR IS RAISED IN AN OBJECT DECLARATION IF +-- A DEFAULT INITIAL VALUE HAS BEEN SPECIFIED WHICH VIOLATES THE +-- CONSTRAINTS OF A RECORD OR AN ARRAY TYPE WHOSE CONSTRAINT +-- DEPENDS ON A DISCRIMINANT, AND NO EXPLICIT INITIALIZATION IS +-- PROVIDED FOR THE OBJECT. + +-- R.WILLIAMS 8/25/86 +-- EDS 7/16/98 AVOID OPTIMIZATION + +WITH REPORT; USE REPORT; +PROCEDURE C37108B IS + + TYPE ARR IS ARRAY (POSITIVE RANGE <>) OF INTEGER; + + TYPE R (P : POSITIVE) IS + RECORD + NULL; + END RECORD; + +BEGIN + TEST ( "C37108B", "CHECK THAT CONSTRAINT_ERROR IS RAISED IN " & + "AN OBJECT DECLARATION IF A DEFAULT INITIAL " & + "VALUE HAS BEEN SPECIFIED WHICH VIOLATES THE " & + "CONSTRAINTS OF A RECORD OR AN ARRAY TYPE " & + "WHOSE CONSTRAINT DEPENDS ON A DISCRIMINANT, " & + "AND NO EXPLICIT INITIALIZATION IS PROVIDED " & + "FOR THE OBJECT" ); + + + BEGIN + DECLARE + TYPE REC1 (D : NATURAL := IDENT_INT (0)) IS + RECORD + A : ARR (D .. 5); + END RECORD; + + BEGIN + DECLARE + R1 : REC1; + + BEGIN + R1.A (1) := IDENT_INT (2); + FAILED ( "NO EXCEPTION RAISED AT DECLARATION OF " & + "R1" & INTEGER'IMAGE(R1.A(5))); --USE R2 + EXCEPTION + WHEN OTHERS => + FAILED ( "EXCEPTION FOR R1 RAISED INSIDE " & + "BLOCK" ); + END; + + EXCEPTION + WHEN CONSTRAINT_ERROR => + NULL; + WHEN OTHERS => + FAILED ( "WRONG EXCEPTION RAISED AT DECLARATION " & + "OF R1" ); + END; + + EXCEPTION + WHEN CONSTRAINT_ERROR => + FAILED ( "CONSTRAINT_ERROR RAISED FOR TYPE " & + "DECLARATION OF REC1" ); + WHEN OTHERS => + FAILED ( "OTHER EXCEPTION RAISED FOR TYPE " & + "DECLARATION OF REC1" ); + END; + + BEGIN + DECLARE + TYPE REC2 (D : INTEGER := IDENT_INT (-1)) IS + RECORD + A : R (P => D); + END RECORD; + + BEGIN + DECLARE + R2 : REC2; + + BEGIN + R2.A := R'(P => IDENT_INT (1)); + FAILED ( "NO EXCEPTION RAISED AT DECLARATION OF " & + "R2" & INTEGER'IMAGE(R2.A.P)); --USE R2 + EXCEPTION + WHEN OTHERS => + FAILED ( "EXCEPTION FOR R2 RAISED INSIDE " & + "BLOCK" ); + END; + + EXCEPTION + WHEN CONSTRAINT_ERROR => + NULL; + WHEN OTHERS => + FAILED ( "WRONG EXCEPTION RAISED AT DECLARATION " & + "OF R2" ); + END; + + EXCEPTION + WHEN CONSTRAINT_ERROR => + FAILED ( "CONSTRAINT_ERROR RAISED FOR TYPE " & + "DECLARATION OF REC2" ); + WHEN OTHERS => + FAILED ( "OTHER EXCEPTION RAISED FOR TYPE " & + "DECLARATION OF REC2" ); + END; + + BEGIN + DECLARE + PACKAGE PRIV IS + TYPE REC3 (D : INTEGER := IDENT_INT (-1)) IS + PRIVATE; + PROCEDURE PROC (R :REC3); + + PRIVATE + TYPE REC3 (D : INTEGER := IDENT_INT (-1)) IS + RECORD + A : R (P => D); + END RECORD; + END PRIV; + + PACKAGE BODY PRIV IS + PROCEDURE PROC (R : REC3) IS + I : INTEGER; + BEGIN + I := IDENT_INT (R.A.P); + IF EQUAL(2, IDENT_INT(1)) THEN + FAILED("IMPOSSIBLE " & INTEGER'IMAGE(I)); --USE I + END IF; + END PROC; + END PRIV; + + USE PRIV; + + BEGIN + DECLARE + R3 : REC3; + + BEGIN + PROC (R3); + FAILED ( "NO EXCEPTION RAISED AT " & + "DECLARATION OF R3" ); + EXCEPTION + WHEN OTHERS => + FAILED ( "EXCEPTION FOR R3 RAISED INSIDE " & + "BLOCK" ); + END; + + EXCEPTION + WHEN CONSTRAINT_ERROR => + NULL; + WHEN OTHERS => + FAILED ( "WRONG EXCEPTION RAISED AT DECLARATION " & + "OF R3" ); + END; + + EXCEPTION + WHEN CONSTRAINT_ERROR => + FAILED ( "CONSTRAINT_ERROR RAISED FOR TYPE " & + "DECLARATION OF REC3" ); + WHEN OTHERS => + FAILED ( "OTHER EXCEPTION RAISED FOR TYPE " & + "DECLARATION OF REC3" ); + END; + + BEGIN + DECLARE + PACKAGE LPRIV IS + TYPE REC4 (D : NATURAL := IDENT_INT (0)) + IS LIMITED PRIVATE; + PROCEDURE PROC (R :REC4); + + PRIVATE + TYPE REC4 (D : NATURAL := IDENT_INT (0)) IS + RECORD + A : ARR (D .. 5); + END RECORD; + END LPRIV; + + PACKAGE BODY LPRIV IS + PROCEDURE PROC (R : REC4) IS + I : INTEGER; + BEGIN + I := IDENT_INT (R.A'FIRST); + IF EQUAL(2, IDENT_INT(1)) THEN + FAILED("IMPOSSIBLE " & INTEGER'IMAGE(I)); --USE I + END IF; + END PROC; + END LPRIV; + + USE LPRIV; + + BEGIN + DECLARE + R4 : REC4; + + BEGIN + PROC (R4); + FAILED ( "NO EXCEPTION RAISED AT " & + "DECLARATION OF R4" ); + EXCEPTION + WHEN OTHERS => + FAILED ( "EXCEPTION FOR R4 RAISED INSIDE " & + "BLOCK" ); + END; + + EXCEPTION + WHEN CONSTRAINT_ERROR => + NULL; + WHEN OTHERS => + FAILED ( "WRONG EXCEPTION RAISED AT DECLARATION " & + "OF R4" ); + END; + + EXCEPTION + WHEN CONSTRAINT_ERROR => + FAILED ( "CONSTRAINT_ERROR RAISED FOR TYPE " & + "DECLARATION OF REC4" ); + WHEN OTHERS => + FAILED ( "OTHER EXCEPTION RAISED FOR TYPE " & + "DECLARATION OF REC4" ); + END; + + RESULT; +END C37108B; diff --git a/gcc-4.9/gcc/testsuite/ada/acats/tests/c3/c37206a.ada b/gcc-4.9/gcc/testsuite/ada/acats/tests/c3/c37206a.ada new file mode 100644 index 000000000..d37c794cb --- /dev/null +++ b/gcc-4.9/gcc/testsuite/ada/acats/tests/c3/c37206a.ada @@ -0,0 +1,65 @@ +-- C37206A.ADA + +-- Grant of Unlimited Rights +-- +-- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687, +-- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained +-- unlimited rights in the software and documentation contained herein. +-- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making +-- this public release, the Government intends to confer upon all +-- recipients unlimited rights equal to those held by the Government. +-- These rights include rights to use, duplicate, release or disclose the +-- released technical data and computer software in whole or in part, in +-- any manner and for any purpose whatsoever, and to have or permit others +-- to do so. +-- +-- DISCLAIMER +-- +-- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR +-- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED +-- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE +-- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE +-- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A +-- PARTICULAR PURPOSE OF SAID MATERIAL. +--* +-- OBJECTIVE: +-- FOR A TYPE WITHOUT DEFAULT DISCRIMINANT VALUES (BUT WITH +-- DISCRIMINANTS) CHECK THAT A TYPEMARK WHICH DENOTES SUCH AN +-- UNCONSTRAINED TYPE CAN BE USED IN: + +-- 1) A SUBTYPE DECLARATION, AND THE SUBTYPE NAME ACTS SIMPLY AS A +-- NEW NAME FOR THE UNCONSTRAINED TYPE; +-- 2) IN A CONSTANT DECLARATION. + +-- HISTORY: +-- AH 08/21/86 CREATED ORIGINAL TEST. +-- DHH 10/19/87 SHORTENED LINES CONTAINING MORE THAN 72 CHARACTERS. +-- DTN 11/13/91 DELETED SUBPARTS (2 and 3). + +WITH REPORT; USE REPORT; +PROCEDURE C37206A IS +BEGIN + + TEST ("C37206A", "FOR TYPE WITH DEFAULT-LESS DISCRIMINANTS, " & + "UNCONSTRAINED TYPE_MARK CAN BE USED IN A SUBTYPE " & + "DECLARATION OR IN A CONSTANT DECLARATION"); + + DECLARE + TYPE REC(DISC : INTEGER) IS + RECORD + NULL; + END RECORD; + + SUBTYPE ST IS REC; -- 1. + + C1 : CONSTANT REC := (DISC => 5); -- 2. + C2 : CONSTANT REC := (DISC => IDENT_INT(5)); -- 2. + BEGIN + + IF C1 /= C2 OR C1 /= (DISC => 5) THEN + FAILED ("CONSTANT DECLARATIONS INCORRECT"); + END IF; + END; + + RESULT; +END C37206A; diff --git a/gcc-4.9/gcc/testsuite/ada/acats/tests/c3/c37207a.ada b/gcc-4.9/gcc/testsuite/ada/acats/tests/c3/c37207a.ada new file mode 100644 index 000000000..e02724088 --- /dev/null +++ b/gcc-4.9/gcc/testsuite/ada/acats/tests/c3/c37207a.ada @@ -0,0 +1,230 @@ +-- C37207A.ADA + +-- Grant of Unlimited Rights +-- +-- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687, +-- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained +-- unlimited rights in the software and documentation contained herein. +-- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making +-- this public release, the Government intends to confer upon all +-- recipients unlimited rights equal to those held by the Government. +-- These rights include rights to use, duplicate, release or disclose the +-- released technical data and computer software in whole or in part, in +-- any manner and for any purpose whatsoever, and to have or permit others +-- to do so. +-- +-- DISCLAIMER +-- +-- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR +-- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED +-- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE +-- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE +-- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A +-- PARTICULAR PURPOSE OF SAID MATERIAL. +--* +-- OBJECTIVE: + +-- FOR A TYPE WITH OR WITHOUT DEFAULT DISCRIMINANT VALUES, CHECK +-- THAT A DISCRIMINANT CONSTRAINT CAN BE SUPPLIED IN THE FOLLOWING +-- CONTEXTS AND HAS THE PROPER EFFECT: + +-- IN A 1) OBJECT_DECLARATION, 2) COMPONENT_DECLARATION OR +-- 3) SUBTYPE INDICATION OF AN ARRAY_TYPE_DEFINITION, AND HENCE, +-- ASSIGNMENTS CANNOT ATTEMPT TO CHANGE THE SPECIFIED DISCRIMINANT +-- VALUES WITHOUT RAISING CONSTRAINT_ERROR + +-- 4) IN AN ACCESS_TYPE_DEFINITION, AND HENCE, ACCESS VALUES +-- OF THIS ACCESS TYPE CANNOT BE ASSIGNED NON-NULL VALUES +-- DESIGNATING OBJECTS WITH DIFFERENT DISCRIMINANT VALUES. + +-- 5) IN AN ALLOCATOR, AND THE ALLOCATED OBJECT HAS THE SPECIFIED +-- DISCRIMINANT VALUES. + +-- 6) IN A FORMAL PARAMETER DECLARATION OF A SUBPROGRAM, AND +-- HENCE, ASSIGNMENTS TO THE FORMAL PARAMETER CANNOT ATTEMPT TO +-- CHANGE THE DISCRIMINANT VALUES WITHOUT RAISING CONSTRAINT_ERROR, +-- CONSTRAINED IS TRUE, AND IF ACTUAL PARAMETERS HAVE DISCRIMINANT +-- VALUES DIFFERENT FROM THE SPECIFIED ONES, CONSTRAINT_ERROR IS +-- RAISED. + +-- HISTORY: + +-- ASL 07/24/81 +-- RJW 08/28/86 CORRECTED SYNTAX ERRORS. +-- JLH 08/07/87 ADDED CODE TO PREVENT DEAD VARIABLE OPTIMIZATION. +-- EDS 07/16/98 AVOID OPTIMIZATION + +WITH REPORT; USE REPORT; +PROCEDURE C37207A IS + +BEGIN + TEST ("C37207A","DISCRIMINANT CONSTRAINT CAN BE SUPPLIED TO " & + "DECLARATIONS AND DEFINITIONS USING TYPES WITH OR WITHOUT " & + "DEFAULT DISCRIMINANT VALUES"); + + DECLARE + TYPE REC1 (DISC : INTEGER := 5) IS + RECORD + NULL; + END RECORD; + + TYPE REC2 (DISC : INTEGER) IS + RECORD + NULL; + END RECORD; + + OBJ1 : REC1(6); -- 1. + OBJ2 : REC2(6); -- 1. + BADOBJ1 : REC1(7); -- 1. + BADOBJ2 : REC2(7); -- 1. + + TYPE REC3 IS + RECORD + COMP1 : REC1(6); -- 2. + COMP2 : REC2(6); -- 2. + END RECORD; + + OBJ3 : REC3; + + TYPE ARR1 IS ARRAY (1..10) OF REC1(6); -- 3. + TYPE ARR2 IS ARRAY (1..10) OF REC2(6); -- 3. + + A1 : ARR1; + A2 : ARR2; + + TYPE REC1_NAME IS ACCESS REC1(6); -- 4. + TYPE REC2_NAME IS ACCESS REC2(6); -- 4. + + ACC1 : REC1_NAME; + ACC2 : REC2_NAME; + + SUBTYPE REC16 IS REC1(6); + SUBTYPE REC26 IS REC2(6); + + PROCEDURE PROC (P1 : IN OUT REC16; -- 6. + P2 : IN OUT REC26) IS -- 6. + BEGIN + IF NOT (P1'CONSTRAINED AND P2'CONSTRAINED) THEN -- 6. + FAILED ("'CONSTRAINED ATTRIBUTE INCORRECT FOR " & + "CONSTRAINED FORMAL PARAMETERS"); + END IF; + BEGIN + P1 := (DISC => 7); -- 6. + FAILED ("CONSTRAINT_ERROR NOT RAISED UPON " & + "ATTEMPT TO CHANGE DISCRIMINANT OF " & + "CONSTRAINED FORMAL PARAMETER " & + INTEGER'IMAGE(P1.DISC)); + EXCEPTION + WHEN CONSTRAINT_ERROR => NULL; + WHEN OTHERS => FAILED ("WRONG EXCEPTION (1)"); + END; + BEGIN + P2 := (DISC => 7); -- 6. + FAILED ("CONSTRAINT_ERROR NOT RAISED UPON " & + "ATTEMPT TO CHANGE DISCRIMINANT OF " & + "CONSTRAINED FORMAL PARAMETER " & + INTEGER'IMAGE(P2.DISC)); + EXCEPTION + WHEN CONSTRAINT_ERROR => NULL; + WHEN OTHERS => FAILED ("WRONG EXCEPTION (2)"); + END; + END PROC; + BEGIN +--------------------------------------------------------------- + + BEGIN + OBJ1 := (DISC => IDENT_INT(7)); -- 1. + FAILED ("CONSTRAINT_ERROR NOT RAISED UPON " & + "ATTEMPT TO CHANGE DISCRIMINANT OF " & + "CONSTRAINED OBJECT"); + IF OBJ1 = (DISC => 7) THEN + COMMENT ("PREVENTING DEAD VARIABLE OPTIMIZATION"); + END IF; + EXCEPTION + WHEN CONSTRAINT_ERROR => NULL; + WHEN OTHERS => FAILED ("WRONG EXCEPTION (3)"); + END; + +--------------------------------------------------------------- + + BEGIN + OBJ3 := ((DISC => IDENT_INT(7)), -- 2. + (DISC => IDENT_INT(7))); -- 2. + FAILED ("CONSTRAINT_ERROR NOT RAISED UPON " & + "ATTEMPT TO CHANGE DISCRIMINANT OF " & + "CONSTRAINED RECORD COMPONENT"); + IF OBJ3 = ((DISC => 7), (DISC => 7)) THEN + COMMENT ("PREVENTING DEAD VARIABLE OPTIMIZATION"); + END IF; + EXCEPTION + WHEN CONSTRAINT_ERROR => NULL; + WHEN OTHERS => FAILED ("WRONG EXCEPTION (4)"); + END; + +-------------------------------------------------------------- + + BEGIN + A2(2) := (DISC => IDENT_INT(7)); -- 3. + FAILED ("CONSTRAINT_ERROR NOT RAISED UPON " & + "ATTEMPT TO CHANGE DISCRIMINANT OF " & + "CONSTRAINED ARRAY COMPONENT"); + IF A2(2) = (DISC => 7) THEN + COMMENT ("PREVENTING DEAD VARIABLE OPTIMIZATION"); + END IF; + EXCEPTION + WHEN CONSTRAINT_ERROR => NULL; + WHEN OTHERS => FAILED ("WRONG EXCEPTION (5)"); + END; + +-------------------------------------------------------------- + + BEGIN + ACC1 := NEW REC1(DISC => IDENT_INT(7)); -- 4. + FAILED ("CONSTRAINT_ERROR NOT RAISED UPON " & + "ATTEMPT TO ASSIGN INCOMPATIBLE OBJECT " & + "TO ACCESS VARIABLE"); + IF ACC1 = NEW REC1(DISC => 7) THEN + COMMENT ("PREVENTING DEAD VARIABLE OPTIMIZATION"); + END IF; + EXCEPTION + WHEN CONSTRAINT_ERROR => NULL; + WHEN OTHERS => FAILED ("WRONG EXCEPTION (6)"); + END; + +---------------------------------------------------------------- + + ACC1 := NEW REC1(DISC => IDENT_INT(6)); -- OK. + + BEGIN + ACC1.ALL := BADOBJ1; -- 5. + FAILED ("CONSTRAINT_ERROR NOT RAISED UPON " & + "ATTEMPT TO ASSIGN INCOMPATIBLE OBJECT " & + "TO ACCESSED OBJECT"); + IF ACC1.ALL = BADOBJ1 THEN + COMMENT ("PREVENT DEAD VARIABLE OPTIMIZATION"); + END IF; + EXCEPTION + WHEN CONSTRAINT_ERROR => NULL; + WHEN OTHERS => FAILED ("WRONG EXCEPTION (7)"); + END; + +----------------------------------------------------------------- + + PROC (OBJ1,OBJ2); -- OK. + + BEGIN + PROC (BADOBJ1,BADOBJ2); -- 6. + FAILED ("CONSTRAINT_ERROR NOT RAISED UPON " & + "PASSING OF CONSTRAINED ACTUAL " & + "PARAMETERS TO DIFFERENTLY CONSTRAINED " & + "FORMAL PARAMETERS"); + EXCEPTION + WHEN CONSTRAINT_ERROR => NULL; + WHEN OTHERS => FAILED ("WRONG EXCEPTION (8)"); + END; + +--------------------------------------------------------------- + END; + + RESULT; +END C37207A; diff --git a/gcc-4.9/gcc/testsuite/ada/acats/tests/c3/c37208a.ada b/gcc-4.9/gcc/testsuite/ada/acats/tests/c3/c37208a.ada new file mode 100644 index 000000000..a83b7ef19 --- /dev/null +++ b/gcc-4.9/gcc/testsuite/ada/acats/tests/c3/c37208a.ada @@ -0,0 +1,172 @@ +-- C37208A.ADA (RA #534/1) + +-- Grant of Unlimited Rights +-- +-- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687, +-- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained +-- unlimited rights in the software and documentation contained herein. +-- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making +-- this public release, the Government intends to confer upon all +-- recipients unlimited rights equal to those held by the Government. +-- These rights include rights to use, duplicate, release or disclose the +-- released technical data and computer software in whole or in part, in +-- any manner and for any purpose whatsoever, and to have or permit others +-- to do so. +-- +-- DISCLAIMER +-- +-- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR +-- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED +-- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE +-- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE +-- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A +-- PARTICULAR PURPOSE OF SAID MATERIAL. +--* +-- FOR A TYPE WITH DEFAULT DISCRIMINANT VALUES, CHECK THAT A +-- DISCRIMINANT CONSTRAINT CAN BE OMITTED IN: + + -- AN OBJECT DECLARATION, AND HENCE ASSIGNMENTS TO THE OBJECT CAN + -- CHANGE ITS DISCRIMINANTS; + + -- A COMPONENT_DECLARATION IN A RECORD TYPE DEFINITION, AND HENCE + -- ASSIGNMENTS TO THE COMPONENT CAN CHANGE THE VALUE OF ITS + -- DISCRIMINANTS; + + -- A SUBTYPE INDICATION IN AN ARRAY TYPE DEFINITION, AND HENCE + -- ASSIGNMENTS TO ONE OF THE COMPONENTS CAN CHANGE ITS + -- DISCRIMINANT VALUES; + + -- A FORMAL PARAMETER OF A SUBPROGRAM; EXCEPT FOR PARAMETERS OF + -- MODE IN, THE 'CONSTRAINED ATTRIBUTE OF THE ACTUAL PARAMETER + -- BECOMES THE 'CONSTRAINED ATTRIBUTE OF THE FORMAL PARAMETER; + -- FOR IN OUT AND OUT PARAMETERS, IF THE 'CONSTRAINED ATTRIBUTE IS + -- FALSE, ASSIGNMENTS TO THE FORMAL PARAMETER CAN CHANGE THE + -- DISCRIMINANTS OF THE ACTUAL PARAMETER; IF THE 'CONSTRAINED + -- ATTRIBUTE IS TRUE, ASSIGNNMENTS THAT ATTEMPT TO CHANGE THE + -- DISCRIMINANTS OF THE ACTUAL PARAMETER RAISE CONSTRAINT_ERROR. + +-- ASL 7/23/81 +-- EDS 7/16/98 AVOID OPTIMIZATION + +WITH REPORT; +PROCEDURE C37208A IS + + USE REPORT; + +BEGIN + TEST ("C37208A","DISCRIMINANT CONSTRAINT CAN BE OMITTED " & + "FROM OBJECT DECLARATION, COMPONENT DECLARATION, SUBTYPE " & + "INDICATION OR FORMAL SUBPROGRAM PARAMETER, IF THE TYPE " & + "HAS DEFAULT DISCRIMINANTS"); + + DECLARE + TYPE REC1(DISC : INTEGER := 7) IS + RECORD + NULL; + END RECORD; + + TYPE REC2 IS + RECORD + COMP : REC1; + END RECORD; + + R : REC2; + U1,U2,U3 : REC1 := (DISC => 3); + C1,C2,C3 : REC1(3) := (DISC => 3); + ARR : ARRAY(INTEGER RANGE 1..10) OF REC1; + ARR2 : ARRAY (1..10) OF REC1(4); + + PROCEDURE PROC(P_IN : IN REC1; + P_OUT : OUT REC1; + P_IN_OUT : IN OUT REC1; + CONSTR : IN BOOLEAN) IS + BEGIN + IF P_OUT'CONSTRAINED /= CONSTR + OR P_IN_OUT'CONSTRAINED /= CONSTR THEN + FAILED ("CONSTRAINED ATTRIBUTES DO NOT MATCH " & + "FOR ACTUAL AND FORMAL PARAMETERS"); + END IF; + + IF P_IN'CONSTRAINED /= IDENT_BOOL(TRUE) THEN + FAILED ("'CONSTRAINED IS FALSE FOR IN " & + "PARAMETER"); + END IF; + + IF NOT CONSTR THEN -- UNCONSTRAINED ACTUAL PARAM + P_OUT := (DISC => IDENT_INT(0)); + P_IN_OUT := (DISC => IDENT_INT(0)); + ELSE + BEGIN + P_OUT := (DISC => IDENT_INT(0)); + FAILED ("DISCRIMINANT OF CONSTRAINED ACTUAL " & + "PARAMETER ILLEGALLY CHANGED - 1"); + EXCEPTION + WHEN CONSTRAINT_ERROR => + NULL; + WHEN OTHERS => + FAILED ("WRONG EXCEPTION - 1"); + END; + + BEGIN + P_IN_OUT := (DISC => IDENT_INT(0)); + FAILED ("DISCRIMINANT OF CONSTRAINED ACTUAL " & + "PARAMETER ILLEGALLY CHANGED - 2"); + EXCEPTION + WHEN CONSTRAINT_ERROR => NULL; + WHEN OTHERS => + FAILED ("WRONG EXCEPTION - 2"); + END; + END IF; + END PROC; + BEGIN + IF U1.DISC /= IDENT_INT(3) THEN + FAILED ("INITIAL DISCRIMINANT VALUE WRONG - U1"); + END IF; + + U1 := (DISC => IDENT_INT(5)); + IF U1.DISC /= 5 THEN + FAILED ("ASSIGNMENT FAILED FOR OBJECT"); + END IF; + + IF R.COMP.DISC /= IDENT_INT(7) THEN + FAILED ("DEFAULT DISCRIMINANT VALUE WRONG - R"); + END IF; + + R.COMP := (DISC => IDENT_INT(5)); + IF R.COMP.DISC /= 5 THEN + FAILED ("ASSIGNMENT FAILED FOR RECORD COMPONENT"); + END IF; + + FOR I IN 1..10 LOOP + IF ARR(I).DISC /= IDENT_INT(7) THEN + FAILED ("DEFAULT DISCRIMINANT VALUE WRONG - ARR"); + END IF; + END LOOP; + + ARR(3) := (DISC => IDENT_INT(5)); + IF ARR(3).DISC /= 5 THEN + FAILED ("ASSIGNMENT FAILED FOR ARRAY COMPONENT"); + END IF; + + IF ARR /= (1..2|4..10 => (DISC => 7), 3 => (DISC => 5)) THEN + FAILED ("MODIFIED WRONG COMPONENTS"); + END IF; + + PROC(C1,C2,C3,IDENT_BOOL(TRUE)); + PROC(U1,U2,U3,IDENT_BOOL(FALSE)); + IF U2.DISC /= 0 OR U3.DISC /= 0 THEN + FAILED ("ASSIGNMENT TO UNCONSTRAINED ACTUAL PARAMETER " & + "FAILED TO CHANGE DISCRIMINANT"); + END IF; + + PROC(ARR(1), ARR(3), ARR(4), FALSE); + IF ARR(3).DISC /= 0 OR ARR(4).DISC /= 0 THEN + FAILED ("ARRAY COMPONENT ASSIGNMENTS DIDN'T CHANGE " & + "DISCRIMINANT OF COMPONENT"); + END IF; + + PROC (ARR2(2), ARR2(5), ARR2(10), TRUE); + END; + + RESULT; +END C37208A; diff --git a/gcc-4.9/gcc/testsuite/ada/acats/tests/c3/c37208b.ada b/gcc-4.9/gcc/testsuite/ada/acats/tests/c3/c37208b.ada new file mode 100644 index 000000000..3fc4e651b --- /dev/null +++ b/gcc-4.9/gcc/testsuite/ada/acats/tests/c3/c37208b.ada @@ -0,0 +1,120 @@ +-- C37208B.ADA + +-- Grant of Unlimited Rights +-- +-- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687, +-- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained +-- unlimited rights in the software and documentation contained herein. +-- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making +-- this public release, the Government intends to confer upon all +-- recipients unlimited rights equal to those held by the Government. +-- These rights include rights to use, duplicate, release or disclose the +-- released technical data and computer software in whole or in part, in +-- any manner and for any purpose whatsoever, and to have or permit others +-- to do so. +-- +-- DISCLAIMER +-- +-- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR +-- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED +-- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE +-- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE +-- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A +-- PARTICULAR PURPOSE OF SAID MATERIAL. +--* +-- FOR A TYPE WITH DEFAULT DISCRIMINANT VALUES, CHECK THAT A +-- DISCRIMINANT CONSTRAINT CAN BE OMITTED IN A GENERIC FORMAL +-- PARAMETER, AND HENCE, FOR BOTH IN AND IN OUT PARAMETERS, THE +-- 'CONSTRAINED ATTRIBUTE OF THE ACTUAL PARAMETER BECOMES THE +-- 'CONSTRAINED ATTRIBUTE OF THE FORMAL PARAMETER, AND, FOR IN +-- OUT PARAMETERS, IF THE 'CONSTRAINED ATTRIBUTE IS FALSE, +-- ASSIGNMENTS TO THE FORMAL PARAMETERS CAN CHANGE THE +-- DISCRIMINANTS OF THE ACTUAL PARAMETER; IF THE 'CONSTRAINED +-- ATTRIBUTE IS TRUE, ASSIGNMENTS THAT ATTEMPT TO CHANGE THE +-- DISCRIMINANTS OF THE ACTUAL PARAMETER RAISE CONSTRAINT_ERROR. + +-- ASL 7/29/81 +-- VKG 1/20/83 +-- EDS 7/16/98 AVOID OPTIMIZATION + +WITH REPORT; +PROCEDURE C37208B IS + + USE REPORT; + +BEGIN + TEST ("C37208B","FOR TYPES WITH DEFAULT DISCRIMINANT " & + "VALUES, DISCRIMINANT CONSTRAINTS CAN BE OMITTED " & + "IN GENERIC FORMAL PARAMETERS, AND THE " & + "'CONSTRAINED ATTRIBUTE HAS CORRECT VALUES " & + "DEPENDING ON THE ACTUAL PARAMETERS"); + + DECLARE + TYPE REC(DISC : INTEGER := 7) IS + RECORD + NULL; + END RECORD; + + KC : CONSTANT REC(3) := (DISC => 3); + KU : CONSTANT REC := (DISC => 3); + OBJC1,OBJC2 : REC(3) := (DISC => 3); + OBJU1,OBJU2 : REC := (DISC => 3); + + GENERIC + P_IN1 : REC; + P_IN2 : REC; + P_IN_OUT : IN OUT REC; + STATUS : BOOLEAN; + PROCEDURE PROC; + + PROCEDURE PROC IS + BEGIN + + IF P_IN1'CONSTRAINED /= TRUE OR + P_IN2'CONSTRAINED /= TRUE OR + P_IN_OUT'CONSTRAINED /= STATUS + THEN + + FAILED ("'CONSTRAINED ATTRIBUTES DO NOT MATCH " & + "FOR ACTUAL AND FORMAL PARAMETERS"); + END IF; + IF NOT STATUS THEN + BEGIN + P_IN_OUT := (DISC => IDENT_INT(7)); + EXCEPTION + WHEN OTHERS => + FAILED ("EXCEPTION RAISED " & + "WHEN TRYING TO " & + "CHANGE UNCONSTRAINED " & + "DISCRIMINANT VALUE"); + END; + ELSE + BEGIN + P_IN_OUT := (DISC => IDENT_INT(7)); + FAILED ("DISCRIMINANT OF CONSTRAINED " & + "ACTUAL PARAMETER ILLEGALLY " & + "CHANGED BY ASSIGNMENT"); + EXCEPTION + WHEN CONSTRAINT_ERROR => NULL; + WHEN OTHERS => FAILED ("WRONG EXCEPTION"); + END; + END IF; + END PROC; + + BEGIN + + DECLARE + PROCEDURE PROC_C IS NEW PROC(KC,OBJC1,OBJC2,IDENT_BOOL(TRUE)); + PROCEDURE PROC_U IS NEW PROC(KU,OBJU1,OBJU2,IDENT_BOOL(FALSE)); + BEGIN + PROC_C; + PROC_U; + IF OBJU2.DISC /= 7 THEN + FAILED ("ASSIGNMENT TO UNCONSTRAINED ACTUAL " & + "PARAMETER FAILED TO CHANGE DISCRIMINANT "); + END IF; + END; + + END; + RESULT; +END C37208B; diff --git a/gcc-4.9/gcc/testsuite/ada/acats/tests/c3/c37209a.ada b/gcc-4.9/gcc/testsuite/ada/acats/tests/c3/c37209a.ada new file mode 100644 index 000000000..52d25077c --- /dev/null +++ b/gcc-4.9/gcc/testsuite/ada/acats/tests/c3/c37209a.ada @@ -0,0 +1,145 @@ +-- C37209A.ADA + +-- Grant of Unlimited Rights +-- +-- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687, +-- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained +-- unlimited rights in the software and documentation contained herein. +-- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making +-- this public release, the Government intends to confer upon all +-- recipients unlimited rights equal to those held by the Government. +-- These rights include rights to use, duplicate, release or disclose the +-- released technical data and computer software in whole or in part, in +-- any manner and for any purpose whatsoever, and to have or permit others +-- to do so. +-- +-- DISCLAIMER +-- +-- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR +-- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED +-- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE +-- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE +-- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A +-- PARTICULAR PURPOSE OF SAID MATERIAL. +--* +-- CHECK THAT CONSTRAINT_ERROR IS NOT RAISED FOR A CONSTANT OBJECT +-- DECLARATION WHOSE SUBTYPE INDICATION SPECIFIES AN UNCONSTRAINED +-- TYPE WITH DEFAULT DISCRIMINANT VALUES AND WHOSE INITIALIZATION +-- EXPRESSION SPECIFIES A VALUE WHOSE DISCRIMINANTS ARE NOT EQUAL TO +-- THE DEFAULT VALUE. + +-- R.WILLIAMS 8/25/86 + +WITH REPORT; USE REPORT; +PROCEDURE C37209A IS + +BEGIN + TEST ( "C37209A", "CHECK THAT CONSTRAINT_ERROR IS NOT RAISED " & + "FOR A CONSTANT OBJECT DECLARATION WHOSE " & + "SUBTYPE INDICATION SPECIFIES AN " & + "UNCONSTRAINED TYPE WITH DEFAULT " & + "DISCRIMINANT VALUES AND WHOSE " & + "INITIALIZATION EXPRESSION SPECIFIES A VALUE " & + "WHOSE DISCRIMINANTS ARE NOT EQUAL TO THE " & + "DEFAULT VALUE" ); + DECLARE + + TYPE REC1 (D : INTEGER := IDENT_INT (5)) IS + RECORD + NULL; + END RECORD; + + BEGIN + DECLARE + R1 : CONSTANT REC1 := (D => IDENT_INT (10)); + BEGIN + COMMENT ( "NO EXCEPTION RAISED AT DECLARATION OF R1" ); + EXCEPTION + WHEN OTHERS => + FAILED ( "EXCEPTION FOR R1 RAISED INSIDE BLOCK" ); + END; + + EXCEPTION + WHEN CONSTRAINT_ERROR => + FAILED ( "CONSTRAINT_ERROR RAISED AT DECLARATION OF " & + "R1" ); + WHEN OTHERS => + FAILED ( "OTHER EXCEPTION RAISED AT DECLARATION OF " & + "R1" ); + END; + + + BEGIN + DECLARE + PACKAGE PRIV IS + TYPE REC2 (D : INTEGER:= IDENT_INT (5)) IS PRIVATE; + R2 : CONSTANT REC2; + + PRIVATE + TYPE REC2 (D : INTEGER := IDENT_INT (5)) IS + RECORD + NULL; + END RECORD; + + R2 : CONSTANT REC2 := (D => IDENT_INT (10)); + END PRIV; + + USE PRIV; + + BEGIN + DECLARE + I : INTEGER := R2.D; + BEGIN + COMMENT ( "NO EXCEPTION RAISED AT DECLARATION " & + "OF R2" ); + END; + END; + + EXCEPTION + WHEN CONSTRAINT_ERROR => + FAILED ( "CONSTRAINT_ERROR RAISED AT DECLARATION OF " & + "R2" ); + WHEN OTHERS => + FAILED ( "OTHER EXCEPTION RAISED AT DECLARATION " & + "OF R2" ); + END; + + BEGIN + DECLARE + PACKAGE LPRIV IS + TYPE REC3 (D : INTEGER:= IDENT_INT (5)) IS + LIMITED PRIVATE; + + R3 : CONSTANT REC3; + + PRIVATE + TYPE REC3 (D : INTEGER := IDENT_INT (5)) IS + RECORD + NULL; + END RECORD; + + R3 : CONSTANT REC3 := (D => IDENT_INT (10)); + END LPRIV; + + USE LPRIV; + + BEGIN + DECLARE + I : INTEGER; + BEGIN + I := R3.D; + COMMENT ( "NO EXCEPTION RAISED AT DECLARATION " & + "OF R3" ); + END; + END; + EXCEPTION + WHEN CONSTRAINT_ERROR => + FAILED ( "CONSTRAINT_ERROR RAISED AT DECLARATION OF " & + "R3" ); + WHEN OTHERS => + FAILED ( "OTHER EXCEPTION RAISED AT DECLARATION " & + "OF R3" ); + END; + + RESULT; +END C37209A; diff --git a/gcc-4.9/gcc/testsuite/ada/acats/tests/c3/c37209b.ada b/gcc-4.9/gcc/testsuite/ada/acats/tests/c3/c37209b.ada new file mode 100644 index 000000000..9b1bfc8d4 --- /dev/null +++ b/gcc-4.9/gcc/testsuite/ada/acats/tests/c3/c37209b.ada @@ -0,0 +1,194 @@ +-- C37209B.ADA + +-- Grant of Unlimited Rights +-- +-- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687, +-- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained +-- unlimited rights in the software and documentation contained herein. +-- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making +-- this public release, the Government intends to confer upon all +-- recipients unlimited rights equal to those held by the Government. +-- These rights include rights to use, duplicate, release or disclose the +-- released technical data and computer software in whole or in part, in +-- any manner and for any purpose whatsoever, and to have or permit others +-- to do so. +-- +-- DISCLAIMER +-- +-- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR +-- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED +-- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE +-- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE +-- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A +-- PARTICULAR PURPOSE OF SAID MATERIAL. +--* +-- OBJECTIVE: +-- CHECK THAT CONSTRAINT_ERROR IS RAISED WHEN THE SUBTYPE +-- INDICATION IN A CONSTANT OBJECT DECLARATION SPECIFIES A +-- CONSTRAINED SUBTYPE WITH DISCRIMINANTS AND THE INITIALIZATION +-- VALUE DOES NOT BELONG TO THE SUBTYPE (I. E., THE DISCRIMINANT +-- VALUE DOES NOT MATCH THOSE SPECIFIED BY THE CONSTRAINT). + +-- HISTORY: +-- RJW 08/25/86 CREATED ORIGINAL TEST +-- VCL 08/19/87 CHANGED THE RETURN TYPE OF FUNTION 'INIT' IN +-- PACKAGE 'PRIV2' SO THAT 'INIT' IS UNCONSTRAINED, +-- THUS NOT RAISING A CONSTRAINT ERROR ON RETURN FROM +-- 'INIT'. + +WITH REPORT; USE REPORT; +PROCEDURE C37209B IS + +BEGIN + TEST ( "C37209B", "CHECK THAT CONSTRAINT_ERROR IS RAISED WHEN " & + "THE SUBTYPE INDICATION IN A CONSTANT " & + "OBJECT DECLARATION SPECIFIES A CONSTRAINED " & + "SUBTYPE WITH DISCRIMINANTS AND THE " & + "INITIALIZATION VALUE DOES NOT BELONG TO " & + "THE SUBTYPE (I. E., THE DISCRIMINANT VALUE " & + "DOES NOT MATCH THOSE SPECIFIED BY THE " & + "CONSTRAINT)" ); + DECLARE + + TYPE REC (D : INTEGER) IS + RECORD + NULL; + END RECORD; + + SUBTYPE REC1 IS REC (IDENT_INT (5)); + BEGIN + DECLARE + R1 : CONSTANT REC1 := (D => IDENT_INT (10)); + I : INTEGER := IDENT_INT (R1.D); + BEGIN + FAILED ( "NO EXCEPTION RAISED FOR DECLARATION OF " & + "R1" ); + EXCEPTION + WHEN OTHERS => + FAILED ( "EXCEPTION FOR R1 RAISED INSIDE BLOCK" ); + END; + + EXCEPTION + WHEN CONSTRAINT_ERROR => + NULL; + WHEN OTHERS => + FAILED ( "OTHER EXCEPTION RAISED AT DECLARATION OF " & + "R1" ); + END; + + + BEGIN + DECLARE + PACKAGE PRIV1 IS + TYPE REC (D : INTEGER) IS PRIVATE; + SUBTYPE REC2 IS REC (IDENT_INT (5)); + R2 : CONSTANT REC2; + + PRIVATE + TYPE REC (D : INTEGER) IS + RECORD + NULL; + END RECORD; + + R2 : CONSTANT REC2 := (D => IDENT_INT (10)); + END PRIV1; + + USE PRIV1; + + BEGIN + DECLARE + I : INTEGER := IDENT_INT (R2.D); + BEGIN + FAILED ( "NO EXCEPTION RAISED AT DECLARATION " & + "OF R2" ); + END; + END; + + EXCEPTION + WHEN CONSTRAINT_ERROR => + NULL; + WHEN OTHERS => + FAILED ( "OTHER EXCEPTION RAISED AT DECLARATION " & + "OF R2" ); + END; + + BEGIN + DECLARE + PACKAGE PRIV2 IS + TYPE REC (D : INTEGER) IS PRIVATE; + SUBTYPE REC3 IS REC (IDENT_INT (5)); + + FUNCTION INIT (D : INTEGER) RETURN REC; + PRIVATE + TYPE REC (D : INTEGER) IS + RECORD + NULL; + END RECORD; + + END PRIV2; + + PACKAGE BODY PRIV2 IS + FUNCTION INIT (D : INTEGER) RETURN REC IS + BEGIN + RETURN (D => IDENT_INT (D)); + END INIT; + END PRIV2; + + USE PRIV2; + + BEGIN + DECLARE + R3 : CONSTANT REC3 := INIT (10); + I : INTEGER := IDENT_INT (R3.D); + BEGIN + FAILED ( "NO EXCEPTION RAISED AT DECLARATION " & + "OF R3" ); + END; + END; + + EXCEPTION + WHEN CONSTRAINT_ERROR => + NULL; + WHEN OTHERS => + FAILED ( "OTHER EXCEPTION RAISED AT DECLARATION " & + "OF R3" ); + END; + + BEGIN + DECLARE + PACKAGE LPRIV IS + TYPE REC (D : INTEGER) IS + LIMITED PRIVATE; + SUBTYPE REC4 IS REC (IDENT_INT (5)); + + R4 : CONSTANT REC4; + + PRIVATE + TYPE REC (D : INTEGER) IS + RECORD + NULL; + END RECORD; + + R4 : CONSTANT REC4 := (D => IDENT_INT (10)); + END LPRIV; + + USE LPRIV; + + BEGIN + DECLARE + I : INTEGER := IDENT_INT (R4.D); + BEGIN + FAILED ( "NO EXCEPTION RAISED AT DECLARATION " & + "OF R4" ); + END; + END; + EXCEPTION + WHEN CONSTRAINT_ERROR => + NULL; + WHEN OTHERS => + FAILED ( "OTHER EXCEPTION RAISED AT DECLARATION " & + "OF R4" ); + END; + + RESULT; +END C37209B; diff --git a/gcc-4.9/gcc/testsuite/ada/acats/tests/c3/c37210a.ada b/gcc-4.9/gcc/testsuite/ada/acats/tests/c3/c37210a.ada new file mode 100644 index 000000000..8542bb5b2 --- /dev/null +++ b/gcc-4.9/gcc/testsuite/ada/acats/tests/c3/c37210a.ada @@ -0,0 +1,116 @@ +-- C37210A.ADA + +-- Grant of Unlimited Rights +-- +-- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687, +-- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained +-- unlimited rights in the software and documentation contained herein. +-- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making +-- this public release, the Government intends to confer upon all +-- recipients unlimited rights equal to those held by the Government. +-- These rights include rights to use, duplicate, release or disclose the +-- released technical data and computer software in whole or in part, in +-- any manner and for any purpose whatsoever, and to have or permit others +-- to do so. +-- +-- DISCLAIMER +-- +-- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR +-- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED +-- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF 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 EXPRESSION IN A DISCRIMINANT ASSOCIATION WITH MORE +-- THAN ONE NAME IS EVALUATED ONCE FOR EACH NAME. + +-- R.WILLIAMS 8/28/86 + +WITH REPORT; USE REPORT; +PROCEDURE C37210A IS + + BUMP : INTEGER := IDENT_INT (0); + + FUNCTION F RETURN INTEGER IS + BEGIN + BUMP := BUMP + 1; + RETURN BUMP; + END F; + + FUNCTION CHECK (STR : STRING) RETURN INTEGER IS + BEGIN + IF BUMP /= 2 THEN + FAILED ( "INCORRECT DISCRIMINANT VALUES FOR " & STR); + END IF; + BUMP := IDENT_INT (0); + RETURN 5; + END CHECK; + +BEGIN + TEST ( "C37210A", "CHECK THAT THE EXPRESSION IN A " & + "DISCRIMINANT ASSOCIATION WITH MORE THAN " & + "ONE NAME IS EVALUATED ONCE FOR EACH NAME" ); + + DECLARE + TYPE REC (D1, D2 : INTEGER) IS + RECORD + NULL; + END RECORD; + + R : REC (D1 | D2 => F); + + I1 : INTEGER := CHECK ( "R" ); + + TYPE ACC IS ACCESS REC; + + AC : ACC (D1 | D2 => F); + + I2 : INTEGER := CHECK ( "AC" ); + + PACKAGE PKG IS + TYPE PRIV (D1, D2 : INTEGER) IS PRIVATE; + TYPE PACC IS ACCESS PRIV; + + TYPE LIM (D1, D2 : INTEGER) IS LIMITED PRIVATE; + TYPE LACC IS ACCESS LIM; + + PRIVATE + TYPE PRIV (D1, D2 : INTEGER) IS + RECORD + NULL; + END RECORD; + + TYPE LIM (D1, D2 : INTEGER) IS + RECORD + NULL; + END RECORD; + END PKG; + + USE PKG; + + BEGIN + + DECLARE + P : PRIV (D1 | D2 => F); + + I1 : INTEGER := CHECK ( "P" ); + + PA : PACC (D1 | D2 => F); + + I2 : INTEGER := CHECK ( "PA" ); + + L : LIM (D1 | D2 => F); + + I3 : INTEGER := CHECK ( "L" ); + + LA : LACC (D1 | D2 => F); + + I : INTEGER; + BEGIN + I := CHECK ( "LA" ); + END; + END; + + RESULT; +END C37210A; diff --git a/gcc-4.9/gcc/testsuite/ada/acats/tests/c3/c37211a.ada b/gcc-4.9/gcc/testsuite/ada/acats/tests/c3/c37211a.ada new file mode 100644 index 000000000..4b718a9ec --- /dev/null +++ b/gcc-4.9/gcc/testsuite/ada/acats/tests/c3/c37211a.ada @@ -0,0 +1,242 @@ +-- C37211A.ADA + +-- Grant of Unlimited Rights +-- +-- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687, +-- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained +-- unlimited rights in the software and documentation contained herein. +-- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making +-- this public release, the Government intends to confer upon all +-- recipients unlimited rights equal to those held by the Government. +-- These rights include rights to use, duplicate, release or disclose the +-- released technical data and computer software in whole or in part, in +-- any manner and for any purpose whatsoever, and to have or permit others +-- to do so. +-- +-- DISCLAIMER +-- +-- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR +-- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED +-- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE +-- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE +-- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A +-- PARTICULAR PURPOSE OF SAID MATERIAL. +--* +-- CHECK THAT CONSTRAINT_ERROR IS RAISED BY A DISCRIMINANT CONSTRAINT +-- IF A VALUE SPECIFIED FOR A DISCRIMINANT DOES NOT LIE IN THE RANGE +-- OF THE DISCRIMINANT. THIS TEST CONTAINS CHECKS FOR SUBTYPE +-- INDICATIONS WHERE THE TYPE MARK DENOTES A RECORD TYPE. + +-- R.WILLIAMS 8/28/86 +-- EDS 7/14/98 AVOID OPTIMIZATION + +WITH REPORT; USE REPORT; +PROCEDURE C37211A IS + + TYPE REC (D : POSITIVE) IS + RECORD + NULL; + END RECORD; + +BEGIN + TEST ( "C37211A", "CHECK THAT CONSTRAINT_ERROR IS RAISED BY " & + "A DISCRIMINANT CONSTRAINT IF A VALUE " & + "SPECIFIED FOR A DISCRIMINANT DOES NOT LIE " & + "IN THE RANGE OF THE DISCRIMINANT WHERE THE " & + "TYPE MARK DENOTES A RECORD TYPE" ); + + BEGIN + DECLARE + SUBTYPE SUBREC IS REC (IDENT_INT (-1)); + BEGIN + DECLARE + SR : SUBREC; + BEGIN + FAILED ( "NO EXCEPTION RAISED AT THE " & + "ELABORATION OF SUBTYPE SUBREC " & INTEGER'IMAGE(SR.D)); + END; + EXCEPTION + WHEN OTHERS => + FAILED ( "EXCEPTION RAISED AT DECLARATION OF " & + "OBJECT SR" ); + END; + + EXCEPTION + WHEN CONSTRAINT_ERROR => + NULL; + WHEN OTHERS => + FAILED ( "WRONG EXCEPTION RAISED AT ELABORATION OF " & + "SUBTYPE SUBREC" ); + END; + + BEGIN + DECLARE + TYPE ARR IS ARRAY (1 .. 10) OF REC (IDENT_INT (-1)); + BEGIN + DECLARE + AR : ARR; + BEGIN + FAILED ( "NO EXCEPTION RAISED AT THE " & + "ELABORATION OF TYPE ARR " & INTEGER'IMAGE(AR(1).D)); + END; + EXCEPTION + WHEN OTHERS => + FAILED ( "EXCEPTION RAISED AT DECLARATION OF " & + "OBJECT AR" ); + END; + + EXCEPTION + WHEN CONSTRAINT_ERROR => + NULL; + WHEN OTHERS => + FAILED ( "WRONG EXCEPTION RAISED AT ELABORATION OF " & + "TYPE ARR" ); + END; + + BEGIN + DECLARE + TYPE REC1 IS + RECORD + X : REC (IDENT_INT (-1)); + END RECORD; + + BEGIN + DECLARE + R1 : REC1; + BEGIN + FAILED ( "NO EXCEPTION RAISED AT THE " & + "ELABORATION OF TYPE REC1 " & INTEGER'IMAGE(R1.X.D)); + END; + EXCEPTION + WHEN OTHERS => + FAILED ( "EXCEPTION RAISED AT DECLARATION OF " & + "OBJECT R1" ); + END; + + EXCEPTION + WHEN CONSTRAINT_ERROR => + NULL; + WHEN OTHERS => + FAILED ( "WRONG EXCEPTION RAISED AT ELABORATION OF " & + "TYPE REC1" ); + END; + + BEGIN + DECLARE + TYPE ACCREC IS ACCESS REC (IDENT_INT (-1)); + BEGIN + DECLARE + ACR : ACCREC; + BEGIN + FAILED ( "NO EXCEPTION RAISED AT THE " & + "ELABORATION OF TYPE ACCREC " & INTEGER'IMAGE(ACR.D)); + END; + EXCEPTION + WHEN OTHERS => + FAILED ( "EXCEPTION RAISED AT DECLARATION OF " & + "OBJECT ACR" ); + END; + + EXCEPTION + WHEN CONSTRAINT_ERROR => + NULL; + WHEN OTHERS => + FAILED ( "WRONG EXCEPTION RAISED AT ELABORATION OF " & + "TYPE ACCREC" ); + END; + + BEGIN + DECLARE + TYPE NEWREC IS NEW REC (IDENT_INT (-1)); + BEGIN + DECLARE + NR : NEWREC; + BEGIN + FAILED ( "NO EXCEPTION RAISED AT THE " & + "ELABORATION OF TYPE NEWREC " & INTEGER'IMAGE(NR.D)); + END; + EXCEPTION + WHEN OTHERS => + FAILED ( "EXCEPTION RAISED AT DECLARATION OF " & + "OBJECT NR" ); + END; + + EXCEPTION + WHEN CONSTRAINT_ERROR => + NULL; + WHEN OTHERS => + FAILED ( "WRONG EXCEPTION RAISED AT ELABORATION OF " & + "TYPE NEWREC" ); + END; + + BEGIN + DECLARE + R : REC (IDENT_INT (-1)); + BEGIN + FAILED ( "NO EXCEPTION RAISED AT THE DECLARATION OF " & + "R " & INTEGER'IMAGE(R.D)); + EXCEPTION + WHEN OTHERS => + FAILED ( "EXCEPTION RAISED INSIDE BLOCK " & + "CONTAINING R" ); + END; + + EXCEPTION + WHEN CONSTRAINT_ERROR => + NULL; + WHEN OTHERS => + FAILED ( "WRONG EXCEPTION RAISED AT DECLARATION OF " & + "R" ); + END; + + BEGIN + DECLARE + TYPE REC_NAME IS ACCESS REC; + BEGIN + DECLARE + RN : REC_NAME := NEW REC (IDENT_INT (-1)); + BEGIN + FAILED ( "NO EXCEPTION RAISED AT THE " & + "DECLARATION OF OBJECT RN " & INTEGER'IMAGE(RN.D)); + END; + EXCEPTION + WHEN CONSTRAINT_ERROR => + NULL; + WHEN OTHERS => + FAILED ( "WRONG EXCEPTION RAISED AT DECLARATION " & + "OF OBJECT RN" ); + END; + EXCEPTION + WHEN OTHERS => + FAILED ( "EXCEPTION RAISED AT ELABORATION OF TYPE " & + "REC_NAME" ); + END; + + BEGIN + DECLARE + TYPE BAD_REC (D : POSITIVE := IDENT_INT (-1)) IS + RECORD + NULL; + END RECORD; + BEGIN + DECLARE + BR : BAD_REC; + BEGIN + FAILED ( "NO EXCEPTION RAISED AT THE " & + "DECLARATION OF OBJECT BR " & INTEGER'IMAGE(BR.D)); + END; + EXCEPTION + WHEN CONSTRAINT_ERROR => + NULL; + WHEN OTHERS => + FAILED ( "WRONG EXCEPTION RAISED AT DECLARATION " & + "OF OBJECT BR" ); + END; + EXCEPTION + WHEN OTHERS => + FAILED ( "EXCEPTION RAISED AT ELABORATION OF TYPE " & + "BAD_REC" ); + END; + + RESULT; +END C37211A; diff --git a/gcc-4.9/gcc/testsuite/ada/acats/tests/c3/c37211b.ada b/gcc-4.9/gcc/testsuite/ada/acats/tests/c3/c37211b.ada new file mode 100644 index 000000000..fbc3591ef --- /dev/null +++ b/gcc-4.9/gcc/testsuite/ada/acats/tests/c3/c37211b.ada @@ -0,0 +1,495 @@ +-- C37211B.ADA + +-- Grant of Unlimited Rights +-- +-- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687, +-- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained +-- unlimited rights in the software and documentation contained herein. +-- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making +-- this public release, the Government intends to confer upon all +-- recipients unlimited rights equal to those held by the Government. +-- These rights include rights to use, duplicate, release or disclose the +-- released technical data and computer software in whole or in part, in +-- any manner and for any purpose whatsoever, and to have or permit others +-- to do so. +-- +-- DISCLAIMER +-- +-- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR +-- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED +-- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE +-- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE +-- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A +-- PARTICULAR PURPOSE OF SAID MATERIAL. +--* +-- CHECK THAT CONSTRAINT_ERROR IS RAISED BY A DISCRIMINANT CONSTRAINT +-- IF A VALUE SPECIFIED FOR A DISCRIMINANT DOES NOT LIE IN THE RANGE +-- OF THE DISCRIMINANT. THIS TEST CONTAINS CHECKS FOR SUBTYPE +-- INDICATIONS WHERE THE TYPE MARK DENOTES A PRIVATE OR LIMITED +-- PRIVATE TYPE, AND THE DISCRIMINANT CONSTRAINT OCCURS AFTER THE FULL +-- DECLARATION OF THE TYPE. + +-- R.WILLIAMS 8/28/86 +-- EDS 7/14/98 AVOID OPTIMIZATION + +WITH REPORT; USE REPORT; +PROCEDURE C37211B IS + + SUBTYPE LIES IS BOOLEAN RANGE FALSE .. FALSE; + + PACKAGE PKG IS + TYPE PRIV (L : LIES) IS PRIVATE; + TYPE LIM (L : LIES) IS LIMITED PRIVATE; + + PRIVATE + TYPE PRIV (L : LIES) IS + RECORD + NULL; + END RECORD; + + TYPE LIM (L : LIES) IS + RECORD + NULL; + END RECORD; + END PKG; + + USE PKG; + +BEGIN + TEST ( "C37211B", "CHECK THAT CONSTRAINT_ERROR IS RAISED BY " & + "A DISCRIMINANT CONSTRAINT IF A VALUE " & + "SPECIFIED FOR A DISCRIMINANT DOES NOT LIE " & + "IN THE RANGE OF THE DISCRIMINANT WHERE THE " & + "TYPE MARK DENOTES A PRIVATE OR LIMITED " & + "PRIVATE TYPE, AND THE DISCRIMINANT " & + "CONSTRAINT OCCURS AFTER THE FULL " & + "DECLARATION OF THE TYPE" ); + + BEGIN + DECLARE + SUBTYPE SUBPRIV IS PRIV (IDENT_BOOL (TRUE)); + BEGIN + DECLARE + SP : SUBPRIV; + BEGIN + FAILED ( "NO EXCEPTION RAISED AT THE " & + "ELABORATION OF SUBTYPE SUBPRIV " & + BOOLEAN'IMAGE(SP.L)); + END; + EXCEPTION + WHEN OTHERS => + FAILED ( "EXCEPTION RAISED AT DECLARATION OF " & + "OBJECT SP" ); + END; + + EXCEPTION + WHEN CONSTRAINT_ERROR => + NULL; + WHEN OTHERS => + FAILED ( "WRONG EXCEPTION RAISED AT ELABORATION OF " & + "SUBTYPE SUBPRIV" ); + END; + + BEGIN + DECLARE + SUBTYPE SUBLIM IS LIM (IDENT_BOOL (TRUE)); + BEGIN + DECLARE + SL : SUBLIM; + BEGIN + FAILED ( "NO EXCEPTION RAISED AT THE " & + "ELABORATION OF SUBTYPE SUBLIM" & + BOOLEAN'IMAGE(SL.L)); + END; + EXCEPTION + WHEN OTHERS => + FAILED ( "EXCEPTION RAISED AT DECLARATION OF " & + "OBJECT SL " ); + END; + + EXCEPTION + WHEN CONSTRAINT_ERROR => + NULL; + WHEN OTHERS => + FAILED ( "WRONG EXCEPTION RAISED AT ELABORATION OF " & + "SUBTYPE SUBLIM" ); + END; + + BEGIN + DECLARE + TYPE PARR IS ARRAY (1 .. 5) OF PRIV (IDENT_BOOL (TRUE)); + BEGIN + DECLARE + PAR : PARR; + BEGIN + FAILED ( "NO EXCEPTION RAISED AT THE " & + "ELABORATION OF TYPE PARR " & + BOOLEAN'IMAGE(PAR(1).L)); + END; + EXCEPTION + WHEN OTHERS => + FAILED ( "EXCEPTION RAISED AT DECLARATION OF " & + "OBJECT PAR" ); + END; + + EXCEPTION + WHEN CONSTRAINT_ERROR => + NULL; + WHEN OTHERS => + FAILED ( "WRONG EXCEPTION RAISED AT ELABORATION OF " & + "TYPE PARR" ); + END; + + BEGIN + DECLARE + TYPE LARR IS ARRAY (1 .. 10) OF LIM (IDENT_BOOL (TRUE)); + BEGIN + DECLARE + LAR : LARR; + BEGIN + FAILED ( "NO EXCEPTION RAISED AT THE " & + "ELABORATION OF TYPE LARR " & + BOOLEAN'IMAGE(LAR(1).L)); + END; + EXCEPTION + WHEN OTHERS => + FAILED ( "EXCEPTION RAISED AT DECLARATION OF " & + "OBJECT LAR" ); + END; + + EXCEPTION + WHEN CONSTRAINT_ERROR => + NULL; + WHEN OTHERS => + FAILED ( "WRONG EXCEPTION RAISED AT ELABORATION OF " & + "TYPE LARR" ); + END; + + BEGIN + DECLARE + TYPE PRIV1 IS + RECORD + X : PRIV (IDENT_BOOL (TRUE)); + END RECORD; + + BEGIN + DECLARE + P1 : PRIV1; + BEGIN + FAILED ( "NO EXCEPTION RAISED AT THE " & + "ELABORATION OF TYPE PRIV1 " & + BOOLEAN'IMAGE(P1.X.L)); + END; + EXCEPTION + WHEN OTHERS => + FAILED ( "EXCEPTION RAISED AT DECLARATION OF " & + "OBJECT P1" ); + END; + + EXCEPTION + WHEN CONSTRAINT_ERROR => + NULL; + WHEN OTHERS => + FAILED ( "WRONG EXCEPTION RAISED AT ELABORATION OF " & + "TYPE PRIV1" ); + END; + + BEGIN + DECLARE + TYPE LIM1 IS + RECORD + X : LIM (IDENT_BOOL (TRUE)); + END RECORD; + + BEGIN + DECLARE + L1 : LIM1; + BEGIN + FAILED ( "NO EXCEPTION RAISED AT THE " & + "ELABORATION OF TYPE LIM1 " & + BOOLEAN'IMAGE(L1.X.L)); + END; + EXCEPTION + WHEN OTHERS => + FAILED ( "EXCEPTION RAISED AT DECLARATION OF " & + "OBJECT L1" ); + END; + + EXCEPTION + WHEN CONSTRAINT_ERROR => + NULL; + WHEN OTHERS => + FAILED ( "WRONG EXCEPTION RAISED AT ELABORATION OF " & + "TYPE LIM1" ); + END; + + BEGIN + DECLARE + TYPE ACCPRIV IS ACCESS PRIV (IDENT_BOOL (TRUE)); + BEGIN + DECLARE + ACP : ACCPRIV; + BEGIN + FAILED ( "NO EXCEPTION RAISED AT THE " & + "ELABORATION OF TYPE ACCPRIV " & + BOOLEAN'IMAGE(ACP.L)); + END; + EXCEPTION + WHEN OTHERS => + FAILED ( "EXCEPTION RAISED AT DECLARATION OF " & + "OBJECT ACP" ); + END; + + EXCEPTION + WHEN CONSTRAINT_ERROR => + NULL; + WHEN OTHERS => + FAILED ( "WRONG EXCEPTION RAISED AT ELABORATION OF " & + "TYPE ACCPRIV" ); + END; + + BEGIN + DECLARE + TYPE ACCLIM IS ACCESS LIM (IDENT_BOOL (TRUE)); + BEGIN + DECLARE + ACL : ACCLIM; + BEGIN + FAILED ( "NO EXCEPTION RAISED AT THE " & + "ELABORATION OF TYPE ACCLIM " & + BOOLEAN'IMAGE(ACL.L)); + END; + EXCEPTION + WHEN OTHERS => + FAILED ( "EXCEPTION RAISED AT DECLARATION OF " & + "OBJECT ACL" ); + END; + + EXCEPTION + WHEN CONSTRAINT_ERROR => + NULL; + WHEN OTHERS => + FAILED ( "WRONG EXCEPTION RAISED AT ELABORATION OF " & + "TYPE ACCLIM" ); + END; + + BEGIN + DECLARE + TYPE NEWPRIV IS NEW PRIV (IDENT_BOOL (TRUE)); + BEGIN + DECLARE + NP : NEWPRIV; + BEGIN + FAILED ( "NO EXCEPTION RAISED AT THE " & + "ELABORATION OF TYPE NEWPRIV " & + BOOLEAN'IMAGE(NP.L)); + END; + EXCEPTION + WHEN OTHERS => + FAILED ( "EXCEPTION RAISED AT DECLARATION OF " & + "OBJECT NP" ); + END; + + EXCEPTION + WHEN CONSTRAINT_ERROR => + NULL; + WHEN OTHERS => + FAILED ( "WRONG EXCEPTION RAISED AT ELABORATION OF " & + "TYPE NEWPRIV" ); + END; + + BEGIN + DECLARE + TYPE NEWLIM IS NEW LIM (IDENT_BOOL (TRUE)); + BEGIN + DECLARE + NL : NEWLIM; + BEGIN + FAILED ( "NO EXCEPTION RAISED AT THE " & + "ELABORATION OF TYPE NEWLIM " & + BOOLEAN'IMAGE(NL.L)); + END; + EXCEPTION + WHEN OTHERS => + FAILED ( "EXCEPTION RAISED AT DECLARATION OF " & + "OBJECT NL" ); + END; + + EXCEPTION + WHEN CONSTRAINT_ERROR => + NULL; + WHEN OTHERS => + FAILED ( "WRONG EXCEPTION RAISED AT ELABORATION OF " & + "TYPE NEWLIM" ); + END; + + BEGIN + DECLARE + P : PRIV (IDENT_BOOL (TRUE)); + BEGIN + FAILED ( "NO EXCEPTION RAISED AT THE DECLARATION OF " & + "P " & BOOLEAN'IMAGE(P.L)); + EXCEPTION + WHEN OTHERS => + FAILED ( "EXCEPTION RAISED INSIDE BLOCK " & + "CONTAINING P" ); + END; + + EXCEPTION + WHEN CONSTRAINT_ERROR => + NULL; + WHEN OTHERS => + FAILED ( "WRONG EXCEPTION RAISED AT DECLARATION OF " & + "P" ); + END; + + BEGIN + DECLARE + L : LIM (IDENT_BOOL (TRUE)); + BEGIN + FAILED ( "NO EXCEPTION RAISED AT THE DECLARATION OF " & + "L " & BOOLEAN'IMAGE(L.L)); + EXCEPTION + WHEN OTHERS => + FAILED ( "EXCEPTION RAISED INSIDE BLOCK " & + "CONTAINING L" ); + END; + + EXCEPTION + WHEN CONSTRAINT_ERROR => + NULL; + WHEN OTHERS => + FAILED ( "WRONG EXCEPTION RAISED AT DECLARATION OF " & + "L" ); + END; + + BEGIN + DECLARE + TYPE PRIV_NAME IS ACCESS PRIV; + BEGIN + DECLARE + PN : PRIV_NAME := NEW PRIV (IDENT_BOOL (TRUE)); + BEGIN + FAILED ( "NO EXCEPTION RAISED AT THE " & + "DECLARATION OF OBJECT PN " & + BOOLEAN'IMAGE(PN.L)); + EXCEPTION + WHEN OTHERS => + FAILED ( "EXCEPTION ATTEMPTING TO USE OBJECT" ); + END; + EXCEPTION + WHEN CONSTRAINT_ERROR => + NULL; + WHEN OTHERS => + FAILED ( "WRONG EXCEPTION RAISED AT DECLARATION " & + "OF OBJECT PN" ); + END; + EXCEPTION + WHEN OTHERS => + FAILED ( "EXCEPTION RAISED AT ELABORATION OF TYPE " & + "PRIV_NAME" ); + END; + + BEGIN + DECLARE + TYPE LIM_NAME IS ACCESS LIM; + BEGIN + DECLARE + LN : LIM_NAME := NEW LIM (IDENT_BOOL (TRUE)); + BEGIN + FAILED ( "NO EXCEPTION RAISED AT THE " & + "DECLARATION OF OBJECT LN " & + BOOLEAN'IMAGE(LN.L)); + EXCEPTION + WHEN OTHERS => + FAILED ( "EXCEPTION ATTEMPTING TO USE OBJECT" ); + END; + EXCEPTION + WHEN CONSTRAINT_ERROR => + NULL; + WHEN OTHERS => + FAILED ( "WRONG EXCEPTION RAISED AT DECLARATION " & + "OF OBJECT LN" ); + END; + EXCEPTION + WHEN OTHERS => + FAILED ( "EXCEPTION RAISED AT ELABORATION OF TYPE " & + "LIM_NAME" ); + END; + + BEGIN + DECLARE + PACKAGE PP IS + TYPE BAD_PRIV (D : LIES := IDENT_BOOL (TRUE)) IS + PRIVATE; + PRIVATE + TYPE BAD_PRIV (D : LIES := IDENT_BOOL (TRUE)) IS + RECORD + NULL; + END RECORD; + END PP; + + USE PP; + BEGIN + DECLARE + BP : BAD_PRIV; + BEGIN + FAILED ( "NO EXCEPTION RAISED AT THE " & + "DECLARATION OF OBJECT BP " & + BOOLEAN'IMAGE(BP.D)); + EXCEPTION + WHEN OTHERS => + FAILED ( "EXCEPTION ATTEMPTING TO USE OBJECT" ); + END; + EXCEPTION + WHEN CONSTRAINT_ERROR => + NULL; + WHEN OTHERS => + FAILED ( "WRONG EXCEPTION RAISED AT DECLARATION " & + "OF OBJECT BP" ); + END; + EXCEPTION + WHEN OTHERS => + FAILED ( "EXCEPTION RAISED AT ELABORATION OF TYPE " & + "BAD_PRIV" ); + END; + + BEGIN + DECLARE + PACKAGE PL IS + TYPE BAD_LIM (D : LIES := IDENT_BOOL (TRUE)) IS + LIMITED PRIVATE; + PRIVATE + TYPE BAD_LIM (D : LIES := IDENT_BOOL (TRUE)) IS + RECORD + NULL; + END RECORD; + END PL; + + USE PL; + BEGIN + DECLARE + BL : BAD_LIM; + BEGIN + FAILED ( "NO EXCEPTION RAISED AT THE " & + "DECLARATION OF OBJECT BL " & + BOOLEAN'IMAGE(BL.D)); + EXCEPTION + WHEN OTHERS => + FAILED ( "EXCEPTION ATTEMPTING TO USE OBJECT" ); + END; + EXCEPTION + WHEN CONSTRAINT_ERROR => + NULL; + WHEN OTHERS => + FAILED ( "WRONG EXCEPTION RAISED AT DECLARATION " & + "OF OBJECT BL" ); + END; + EXCEPTION + WHEN OTHERS => + FAILED ( "EXCEPTION RAISED AT ELABORATION OF TYPE " & + "BAD_LIM" ); + END; + + RESULT; +END C37211B; diff --git a/gcc-4.9/gcc/testsuite/ada/acats/tests/c3/c37211c.ada b/gcc-4.9/gcc/testsuite/ada/acats/tests/c3/c37211c.ada new file mode 100644 index 000000000..ba15964d0 --- /dev/null +++ b/gcc-4.9/gcc/testsuite/ada/acats/tests/c3/c37211c.ada @@ -0,0 +1,426 @@ +-- C37211C.ADA + +-- Grant of Unlimited Rights +-- +-- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687, +-- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained +-- unlimited rights in the software and documentation contained herein. +-- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making +-- this public release, the Government intends to confer upon all +-- recipients unlimited rights equal to those held by the Government. +-- These rights include rights to use, duplicate, release or disclose the +-- released technical data and computer software in whole or in part, in +-- any manner and for any purpose whatsoever, and to have or permit others +-- to do so. +-- +-- DISCLAIMER +-- +-- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR +-- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED +-- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE +-- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE +-- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A +-- PARTICULAR PURPOSE OF SAID MATERIAL. +--* +-- CHECK THAT CONSTRAINT_ERROR IS RAISED BY A DISCRIMINANT CONSTRAINT +-- IF A VALUE SPECIFIED FOR A DISCRIMINANT DOES NOT LIE IN THE RANGE +-- OF THE DISCRIMINANT. THIS TEST CONTAINS CHECKS FOR SUBTYPE +-- INDICATIONS WHERE THE TYPE MARK DENOTES A PRIVATE OR LIMITED +-- PRIVATE TYPE, THE DISCRIMINANT CONSTRAINT OCCURS BEFORE THE FULL +-- DECLARATION OF THE TYPE, AND THERE ARE NO COMPONENTS OF THE TYPE +-- DEPENDENT ON THE DISCRIMINANT. + +-- R.WILLIAMS 8/28/86 +-- EDS 7/14/98 AVOID OPTIMIZATION + +WITH REPORT; USE REPORT; +PROCEDURE C37211C IS + + GLOBAL : BOOLEAN; + + SUBTYPE LIES IS BOOLEAN RANGE FALSE .. FALSE; + + FUNCTION SWITCH (B : BOOLEAN) RETURN BOOLEAN IS + BEGIN + GLOBAL := B; + RETURN B; + END SWITCH; + +BEGIN + TEST ( "C37211C", "CHECK THAT CONSTRAINT_ERROR IS RAISED BY " & + "A DISCRIMINANT CONSTRAINT IF A VALUE " & + "SPECIFIED FOR A DISCRIMINANT DOES NOT LIE " & + "IN THE RANGE OF THE DISCRIMINANT WHERE THE " & + "TYPE MARK DENOTES A PRIVATE OR LIMITED " & + "PRIVATE TYPE, AND THE DISCRIMINANT " & + "CONSTRAINT OCCURS BEFORE THE FULL " & + "DECLARATION OF THE TYPE" ); + + BEGIN + DECLARE + + B1 : BOOLEAN := SWITCH (TRUE); + + PACKAGE PP IS + TYPE PRIV1 (D : LIES) IS PRIVATE; + SUBTYPE SUBPRIV IS PRIV1 (IDENT_BOOL (TRUE)); + + B2 : BOOLEAN := SWITCH (FALSE); + + PRIVATE + TYPE PRIV1 (D : LIES) IS + RECORD + NULL; + END RECORD; + END PP; + + USE PP; + BEGIN + DECLARE + SP : SUBPRIV; + BEGIN + FAILED ( "NO EXCEPTION RAISED AT THE " & + "ELABORATION OF SUBTYPE SUBPRIV " & BOOLEAN'IMAGE(SP.D)); + END; + EXCEPTION + WHEN OTHERS => + FAILED ( "EXCEPTION RAISED AT DECLARATION OF " & + "OBJECT SP" ); + END; + + EXCEPTION + WHEN CONSTRAINT_ERROR => + IF GLOBAL THEN + NULL; + ELSE + FAILED ( "EXCEPTION RAISED AT ELABORATION OF " & + "FULL TYPE PRIV1 NOT SUBTYPE SUBPRIV" ); + END IF; + WHEN OTHERS => + FAILED ( "WRONG EXCEPTION RAISED AT ELABORATION OF " & + "SUBTYPE SUBPRIV" ); + END; + + BEGIN + DECLARE + + B1 : BOOLEAN := SWITCH (TRUE); + + PACKAGE PL IS + TYPE LIM1 (D : LIES) IS LIMITED PRIVATE; + SUBTYPE SUBLIM IS LIM1 (IDENT_BOOL (TRUE)); + + B2 : BOOLEAN := SWITCH (FALSE); + + PRIVATE + TYPE LIM1 (D : LIES) IS + RECORD + NULL; + END RECORD; + END PL; + + USE PL; + BEGIN + DECLARE + SL : SUBLIM; + BEGIN + FAILED ( "NO EXCEPTION RAISED AT THE " & + "ELABORATION OF SUBTYPE SUBLIM " & BOOLEAN'IMAGE(SL.D)); + END; + EXCEPTION + WHEN OTHERS => + FAILED ( "EXCEPTION RAISED AT DECLARATION OF " & + "OBJECT SL" ); + END; + + EXCEPTION + WHEN CONSTRAINT_ERROR => + IF GLOBAL THEN + NULL; + ELSE + FAILED ( "EXCEPTION RAISED AT ELABORATION OF " & + "FULL TYPE LIM1 NOT SUBTYPE SUBLIM" ); + END IF; + WHEN OTHERS => + FAILED ( "WRONG EXCEPTION RAISED AT ELABORATION OF " & + "SUBTYPE SUBLIM" ); + END; + + BEGIN + DECLARE + B1 : BOOLEAN := SWITCH (TRUE); + + PACKAGE PP IS + TYPE PRIV2 (D : LIES) IS PRIVATE; + TYPE PARR IS ARRAY (1 .. 5) OF + PRIV2 (IDENT_BOOL (TRUE)); + + B2 : BOOLEAN := SWITCH (FALSE); + + PRIVATE + TYPE PRIV2 (D : LIES) IS + RECORD + NULL; + END RECORD; + END PP; + + USE PP; + BEGIN + DECLARE + PAR : PARR; + BEGIN + FAILED ( "NO EXCEPTION RAISED AT THE " & + "ELABORATION OF TYPE PARR " & BOOLEAN'IMAGE(PAR(1).D)); + END; + EXCEPTION + WHEN OTHERS => + FAILED ( "EXCEPTION RAISED AT DECLARATION OF " & + "OBJECT PAR" ); + END; + + EXCEPTION + WHEN CONSTRAINT_ERROR => + IF GLOBAL THEN + NULL; + ELSE + FAILED ( "EXCEPTION RAISED AT ELABORATION OF " & + "FULL TYPE PRIV2 NOT TYPE PARR" ); + END IF; + WHEN OTHERS => + FAILED ( "WRONG EXCEPTION RAISED AT ELABORATION OF " & + "TYPE PARR" ); + END; + + BEGIN + DECLARE + B1 : BOOLEAN := SWITCH (TRUE); + + PACKAGE PL IS + TYPE LIM2 (D : LIES) IS LIMITED PRIVATE; + TYPE LARR IS ARRAY (1 .. 5) OF + LIM2 (IDENT_BOOL (TRUE)); + + B2 : BOOLEAN := SWITCH (FALSE); + + PRIVATE + TYPE LIM2 (D : LIES) IS + RECORD + NULL; + END RECORD; + END PL; + + USE PL; + BEGIN + DECLARE + LAR : LARR; + BEGIN + FAILED ( "NO EXCEPTION RAISED AT THE " & + "ELABORATION OF TYPE LARR " & BOOLEAN'IMAGE(LAR(1).D)); + END; + EXCEPTION + WHEN OTHERS => + FAILED ( "EXCEPTION RAISED AT DECLARATION OF " & + "OBJECT LAR" ); + END; + + EXCEPTION + WHEN CONSTRAINT_ERROR => + IF GLOBAL THEN + NULL; + ELSE + FAILED ( "EXCEPTION RAISED AT ELABORATION OF " & + "FULL TYPE LIM2 NOT TYPE LARR" ); + END IF; + WHEN OTHERS => + FAILED ( "WRONG EXCEPTION RAISED AT ELABORATION OF " & + "TYPE LARR" ); + END; + + BEGIN + DECLARE + B1 : BOOLEAN := SWITCH (TRUE); + + PACKAGE PP IS + TYPE PRIV3 (D : LIES) IS PRIVATE; + + TYPE PRIV4 IS + RECORD + X : PRIV3 (IDENT_BOOL (TRUE)); + END RECORD; + + B2 : BOOLEAN := SWITCH (FALSE); + + PRIVATE + TYPE PRIV3 (D : LIES) IS + RECORD + NULL; + END RECORD; + END PP; + + USE PP; + BEGIN + DECLARE + P4 : PRIV4; + BEGIN + FAILED ( "NO EXCEPTION RAISED AT THE " & + "ELABORATION OF TYPE PRIV4 " & BOOLEAN'IMAGE(P4.X.D)); + END; + EXCEPTION + WHEN OTHERS => + FAILED ( "EXCEPTION RAISED AT DECLARATION OF " & + "OBJECT P4" ); + END; + + EXCEPTION + WHEN CONSTRAINT_ERROR => + IF GLOBAL THEN + NULL; + ELSE + FAILED ( "EXCEPTION RAISED AT ELABORATION OF " & + "FULL TYPE PRIV3 NOT TYPE PRIV4" ); + END IF; + WHEN OTHERS => + FAILED ( "WRONG EXCEPTION RAISED AT ELABORATION OF " & + "TYPE PRIV4" ); + END; + + BEGIN + DECLARE + B1 : BOOLEAN := SWITCH (TRUE); + + PACKAGE PL IS + TYPE LIM3 (D : LIES) IS LIMITED PRIVATE; + + TYPE LIM4 IS + RECORD + X : LIM3 (IDENT_BOOL (TRUE)); + END RECORD; + + B2 : BOOLEAN := SWITCH (FALSE); + + PRIVATE + TYPE LIM3 (D : LIES) IS + RECORD + NULL; + END RECORD; + END PL; + + USE PL; + BEGIN + DECLARE + L4 : LIM4; + BEGIN + FAILED ( "NO EXCEPTION RAISED AT THE " & + "ELABORATION OF TYPE LIM4 " & BOOLEAN'IMAGE(L4.X.D)); + END; + EXCEPTION + WHEN OTHERS => + FAILED ( "EXCEPTION RAISED AT DECLARATION OF " & + "OBJECT L4" ); + END; + + EXCEPTION + WHEN CONSTRAINT_ERROR => + IF GLOBAL THEN + NULL; + ELSE + FAILED ( "EXCEPTION RAISED AT ELABORATION OF " & + "FULL TYPE LIM3 NOT TYPE LIM4" ); + END IF; + WHEN OTHERS => + FAILED ( "WRONG EXCEPTION RAISED AT ELABORATION OF " & + "TYPE LIM4" ); + END; + + BEGIN + DECLARE + B1 : BOOLEAN := SWITCH (TRUE); + + PACKAGE PP IS + TYPE PRIV5 (D : LIES) IS PRIVATE; + TYPE ACCPRIV IS ACCESS PRIV5 (IDENT_BOOL (TRUE)); + + B2 : BOOLEAN := SWITCH (FALSE); + + PRIVATE + TYPE PRIV5 (D : LIES) IS + RECORD + NULL; + END RECORD; + END PP; + + USE PP; + + BEGIN + DECLARE + ACP : ACCPRIV; + BEGIN + FAILED ( "NO EXCEPTION RAISED AT THE " & + "ELABORATION OF TYPE ACCPRIV " & BOOLEAN'IMAGE(ACP.D)); + END; + EXCEPTION + WHEN OTHERS => + FAILED ( "EXCEPTION RAISED AT DECLARATION OF " & + "OBJECT ACP" ); + END; + + EXCEPTION + WHEN CONSTRAINT_ERROR => + IF GLOBAL THEN + NULL; + ELSE + FAILED ( "EXCEPTION RAISED AT ELABORATION OF " & + "FULL TYPE PRIV5 NOT TYPE ACCPRIV" ); + END IF; + WHEN OTHERS => + FAILED ( "WRONG EXCEPTION RAISED AT ELABORATION OF " & + "TYPE ACCPRIV" ); + END; + + BEGIN + DECLARE + B1 : BOOLEAN := SWITCH (TRUE); + + PACKAGE PL IS + TYPE LIM5 (D : LIES) IS LIMITED PRIVATE; + TYPE ACCLIM IS ACCESS LIM5 (IDENT_BOOL (TRUE)); + + B2 : BOOLEAN := SWITCH (FALSE); + + PRIVATE + TYPE LIM5 (D : LIES) IS + RECORD + NULL; + END RECORD; + END PL; + + USE PL; + + BEGIN + DECLARE + ACL : ACCLIM; + BEGIN + FAILED ( "NO EXCEPTION RAISED AT THE " & + "ELABORATION OF TYPE ACCLIM " & BOOLEAN'IMAGE(ACL.D)); + END; + EXCEPTION + WHEN OTHERS => + FAILED ( "EXCEPTION RAISED AT DECLARATION OF " & + "OBJECT ACL" ); + END; + + EXCEPTION + WHEN CONSTRAINT_ERROR => + IF GLOBAL THEN + NULL; + ELSE + FAILED ( "EXCEPTION RAISED AT ELABORATION OF " & + "FULL TYPE LIM5 NOT TYPE ACCLIM" ); + END IF; + WHEN OTHERS => + FAILED ( "WRONG EXCEPTION RAISED AT ELABORATION OF " & + "TYPE ACCLIM" ); + END; + + RESULT; +END C37211C; diff --git a/gcc-4.9/gcc/testsuite/ada/acats/tests/c3/c37211d.ada b/gcc-4.9/gcc/testsuite/ada/acats/tests/c3/c37211d.ada new file mode 100644 index 000000000..8d623c8bd --- /dev/null +++ b/gcc-4.9/gcc/testsuite/ada/acats/tests/c3/c37211d.ada @@ -0,0 +1,102 @@ +-- C37211D.ADA + +-- Grant of Unlimited Rights +-- +-- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687, +-- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained +-- unlimited rights in the software and documentation contained herein. +-- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making +-- this public release, the Government intends to confer upon all +-- recipients unlimited rights equal to those held by the Government. +-- These rights include rights to use, duplicate, release or disclose the +-- released technical data and computer software in whole or in part, in +-- any manner and for any purpose whatsoever, and to have or permit others +-- to do so. +-- +-- DISCLAIMER +-- +-- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR +-- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED +-- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE +-- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE +-- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A +-- PARTICULAR PURPOSE OF SAID MATERIAL. +--* +-- CHECK THAT CONSTRAINT_ERROR IS RAISED BY A DISCRIMINANT CONSTRAINT +-- IF A VALUE SPECIFIED FOR A DISCRIMINANT DOES NOT LIE IN THE RANGE +-- OF THE DISCRIMINANT. THIS TEST CONTAINS CHECKS FOR SUBTYPE +-- INDICATIONS WHERE THE TYPE MARK DENOTES AN INCOMPLETE TYPE. + +-- R.WILLIAMS 8/28/86 +-- EDS 7/14/98 AVOID OPTIMIZATION + +WITH REPORT; USE REPORT; +PROCEDURE C37211D IS + + GLOBAL : BOOLEAN; + + TYPE DAY IS (SUN, MON, TUE, WED, THU, FRI, SAT); + + SUBTYPE WEEKDAY IS DAY RANGE MON .. FRI; + + FUNCTION SWITCH (B : BOOLEAN) RETURN BOOLEAN IS + BEGIN + GLOBAL := B; + RETURN B; + END SWITCH; + + FUNCTION IDENT (D : DAY) RETURN DAY IS + BEGIN + RETURN DAY'VAL (IDENT_INT (DAY'POS (D))); + END IDENT; + +BEGIN + TEST ( "C37211D", "CHECK THAT CONSTRAINT_ERROR IS RAISED BY " & + "A DISCRIMINANT CONSTRAINT IF A VALUE " & + "SPECIFIED FOR A DISCRIMINANT DOES NOT LIE " & + "IN THE RANGE OF THE DISCRIMINANT WHERE THE " & + "TYPE MARK DENOTES AN INCOMPLETE TYPE" ); + + BEGIN + DECLARE + + B1 : BOOLEAN := SWITCH (TRUE); + + TYPE REC (D : WEEKDAY); + + TYPE ACCREC IS ACCESS REC (IDENT (SUN)); + + B2 : BOOLEAN := SWITCH (FALSE); + + TYPE REC (D : WEEKDAY) IS + RECORD + NULL; + END RECORD; + BEGIN + DECLARE + AC : ACCREC; + BEGIN + FAILED ( "NO EXCEPTION RAISED AT THE " & + "ELABORATION OF TYPE ACCREC " & DAY'IMAGE(AC.D)); + END; + EXCEPTION + WHEN OTHERS => + FAILED ( "EXCEPTION RAISED AT DECLARATION OF " & + "OBJECT AC" ); + END; + + EXCEPTION + WHEN CONSTRAINT_ERROR => + IF GLOBAL THEN + NULL; + ELSE + FAILED ( "EXCEPTION RAISED AT ELABORATION OF " & + "FULL TYPE REC NOT TYPE ACCREC" ); + END IF; + WHEN OTHERS => + FAILED ( "WRONG EXCEPTION RAISED AT ELABORATION OF " & + "TYPE ACCREC" ); + END; + + RESULT; +END C37211D; diff --git a/gcc-4.9/gcc/testsuite/ada/acats/tests/c3/c37211e.ada b/gcc-4.9/gcc/testsuite/ada/acats/tests/c3/c37211e.ada new file mode 100644 index 000000000..c4b12fa44 --- /dev/null +++ b/gcc-4.9/gcc/testsuite/ada/acats/tests/c3/c37211e.ada @@ -0,0 +1,233 @@ +-- C37211E.ADA + +-- Grant of Unlimited Rights +-- +-- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687, +-- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained +-- unlimited rights in the software and documentation contained herein. +-- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making +-- this public release, the Government intends to confer upon all +-- recipients unlimited rights equal to those held by the Government. +-- These rights include rights to use, duplicate, release or disclose the +-- released technical data and computer software in whole or in part, in +-- any manner and for any purpose whatsoever, and to have or permit others +-- to do so. +-- +-- DISCLAIMER +-- +-- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR +-- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED +-- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE +-- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE +-- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A +-- PARTICULAR PURPOSE OF SAID MATERIAL. +--* +-- CHECK THAT CONSTRAINT_ERROR IS RAISED BY A DISCRIMINANT CONSTRAINT +-- IF A VALUE SPECIFIED FOR A DISCRIMINANT DOES NOT LIE IN THE RANGE +-- OF THE DISCRIMINANT. + +-- R.WILLIAMS 8/28/86 +-- PWN 10/27/95 REMOVED CHECK WHERE CONSTRAINT RULES HAVE CHANGED. +-- PWN 12/03/95 CORRECTED FORMATING PROBLEM. +-- TMB 11/20/96 REINTRODUCED CHECK REMOVED ON 10/27 WITH ADA95 CHANGES +-- TMB 12/2/96 DELETED CHECK OF CONSTRAINED ACCESS TYPE +-- EDS 07/14/98 AVOID OPTIMIZATION + +WITH REPORT; USE REPORT; +PROCEDURE C37211E IS + + TYPE REC (D : POSITIVE) IS + RECORD + NULL; + END RECORD; + + TYPE ACC IS ACCESS REC; +BEGIN + TEST ( "C37211E", "CHECK THAT CONSTRAINT_ERROR IS RAISED BY " & + "A DISCRIMINANT CONSTRAINT IF A VALUE " & + "SPECIFIED FOR A DISCRIMINANT DOES NOT LIE " & + "IN THE RANGE OF THE DISCRIMINANT WHERE THE " & + "TYPE MARK DENOTES AN ACCESS TYPE" ); + + BEGIN + DECLARE + SUBTYPE SUBACC IS ACC (IDENT_INT (-1)); + BEGIN + DECLARE + SA : SUBACC; + BEGIN + FAILED ( "NO EXCEPTION RAISED AT THE " & + "ELABORATION OF SUBTYPE SUBACC " & + INTEGER'IMAGE(SA.D)); + END; + EXCEPTION + WHEN OTHERS => + FAILED ( "EXCEPTION RAISED AT DECLARATION OF " & + "OBJECT SA" ); + END; + + EXCEPTION + WHEN CONSTRAINT_ERROR => + NULL; + WHEN OTHERS => + FAILED ( "WRONG EXCEPTION RAISED AT ELABORATION OF " & + "SUBTYPE SUBACC" ); + END; + + BEGIN + DECLARE + TYPE ARR IS ARRAY (1 .. 10) OF ACC (IDENT_INT (-1)); + BEGIN + DECLARE + AR : ARR; + BEGIN + FAILED ( "NO EXCEPTION RAISED AT THE " & + "ELABORATION OF TYPE ARR " & + INTEGER'IMAGE(AR(1).D)); + END; + EXCEPTION + WHEN OTHERS => + FAILED ( "EXCEPTION RAISED AT DECLARATION OF " & + "OBJECT AR" ); + END; + + EXCEPTION + WHEN CONSTRAINT_ERROR => + NULL; + WHEN OTHERS => + FAILED ( "WRONG EXCEPTION RAISED AT ELABORATION OF " & + "TYPE ARR" ); + END; + + BEGIN + DECLARE + TYPE REC1 IS + RECORD + X : ACC (IDENT_INT (-1)); + END RECORD; + + BEGIN + DECLARE + R1 : REC1; + BEGIN + FAILED ( "NO EXCEPTION RAISED AT THE " & + "ELABORATION OF TYPE REC1 " & INTEGER'IMAGE(R1.X.D)); + END; + EXCEPTION + WHEN OTHERS => + FAILED ( "EXCEPTION RAISED AT DECLARATION OF " & + "OBJECT R1" ); + END; + + EXCEPTION + WHEN CONSTRAINT_ERROR => + NULL; + WHEN OTHERS => + FAILED ( "WRONG EXCEPTION RAISED AT ELABORATION OF " & + "TYPE REC1" ); + END; + + BEGIN + DECLARE + TYPE ACCA IS ACCESS ACC (IDENT_INT (-1)); + BEGIN + DECLARE + ACA : ACCA; + BEGIN + FAILED ( "NO EXCEPTION RAISED AT THE " & + "ELABORATION OF TYPE ACCA " & + INTEGER'IMAGE(ACA.ALL.D)); + END; + EXCEPTION + WHEN OTHERS => + FAILED ( "EXCEPTION RAISED AT DECLARATION OF " & + "OBJECT ACA" ); + END; + + EXCEPTION + WHEN CONSTRAINT_ERROR => + NULL; + WHEN OTHERS => + FAILED ( "WRONG EXCEPTION RAISED AT ELABORATION OF " & + "TYPE ACCA" ); + END; + + BEGIN + DECLARE + TYPE NEWACC IS NEW ACC (IDENT_INT (-1)); + BEGIN + DECLARE + NA : NEWACC; + BEGIN + FAILED ( "NO EXCEPTION RAISED AT THE " & + "ELABORATION OF TYPE NEWACC " & + INTEGER'IMAGE(NA.D)); + END; + EXCEPTION + WHEN OTHERS => + FAILED ( "EXCEPTION RAISED AT DECLARATION OF " & + "OBJECT NA" ); + END; + + EXCEPTION + WHEN CONSTRAINT_ERROR => + NULL; + WHEN OTHERS => + FAILED ( "WRONG EXCEPTION RAISED AT ELABORATION OF " & + "TYPE NEWACC" ); + END; + + BEGIN + DECLARE + A : ACC (IDENT_INT (-1)); + BEGIN + FAILED ( "NO EXCEPTION RAISED AT THE DECLARATION OF " & + "A " & INTEGER'IMAGE(A.D)); + EXCEPTION + WHEN OTHERS => + FAILED ( "EXCEPTION RAISED INSIDE BLOCK " & + "CONTAINING A" ); + END; + + EXCEPTION + WHEN CONSTRAINT_ERROR => + NULL; + WHEN OTHERS => + FAILED ( "WRONG EXCEPTION RAISED AT DECLARATION OF " & + "A" ); + END; + + + BEGIN + DECLARE + TYPE BAD_ACC (D : POSITIVE := IDENT_INT (-1)) IS + RECORD + NULL; + END RECORD; + BEGIN + DECLARE + BAC : BAD_ACC; + BEGIN + FAILED ( "NO EXCEPTION RAISED AT THE " & + "DECLARATION OF OBJECT BAC " & + INTEGER'IMAGE(BAC.D)); + EXCEPTION + WHEN OTHERS => + FAILED ( "EXCEPTION RAISED INSIDE BLOCK " & + "DECLARING BAC" ); + END; + EXCEPTION + WHEN CONSTRAINT_ERROR => + NULL; + WHEN OTHERS => + FAILED ( "WRONG EXCEPTION RAISED AT DECLARATION " & + "OF OBJECT BAC" ); + END; + EXCEPTION + WHEN OTHERS => + FAILED ( "EXCEPTION RAISED AT ELABORATION OF TYPE " & + "BAD_ACC" ); + END; + + RESULT; +END C37211E; diff --git a/gcc-4.9/gcc/testsuite/ada/acats/tests/c3/c37213b.ada b/gcc-4.9/gcc/testsuite/ada/acats/tests/c3/c37213b.ada new file mode 100644 index 000000000..2117ece0b --- /dev/null +++ b/gcc-4.9/gcc/testsuite/ada/acats/tests/c3/c37213b.ada @@ -0,0 +1,241 @@ +-- C37213B.ADA + +-- Grant of Unlimited Rights +-- +-- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687, +-- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained +-- unlimited rights in the software and documentation contained herein. +-- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making +-- this public release, the Government intends to confer upon all +-- recipients unlimited rights equal to those held by the Government. +-- These rights include rights to use, duplicate, release or disclose the +-- released technical data and computer software in whole or in part, in +-- any manner and for any purpose whatsoever, and to have or permit others +-- to do so. +-- +-- DISCLAIMER +-- +-- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR +-- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED +-- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF 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 DISCRIMINANT CONSTRAINT +-- DEPENDS ON A DISCRIMINANT, THE NON-DISCRIMINANT EXPRESSIONS IN THE +-- CONSTRAINT ARE EVALUATED WHEN THE COMPONENT SUBTYPE DEFINITION IS +-- ELABORATED, BUT THE VALUES ARE CHECKED WHEN THE RECORD TYPE IS: +-- +-- CASE B: USED WITHOUT A CONSTRAINT ONLY IN AN ALLOCATOR OR OBJECT +-- DECLARATION. + +-- JBG 10/17/86 + +WITH REPORT; USE REPORT; +PROCEDURE C37213B IS + + SUBTYPE SM IS INTEGER RANGE 1..10; + + TYPE REC (D1, D2 : SM) IS + RECORD NULL; END RECORD; + + F1_CONS : INTEGER := 2; + + FUNCTION CHK ( + CONS : INTEGER; + VALUE : INTEGER; + MESSAGE : STRING) RETURN BOOLEAN IS + BEGIN + IF CONS /= VALUE THEN + FAILED (MESSAGE & ": CONS IS " & + INTEGER'IMAGE(CONS)); + END IF; + RETURN TRUE; + END CHK; + + FUNCTION F1 RETURN INTEGER IS + BEGIN + F1_CONS := F1_CONS - IDENT_INT(1); + RETURN F1_CONS; + END F1; + +BEGIN + TEST ("C37213B", "CHECK EVALUATION OF DISCRIMINANT EXPRESSIONS " & + "WHEN CONSTRAINT DEPENDS ON DISCRIMINANT, " & + "AND DISCRIMINANTS HAVE DEFAULTS"); + +-- CASE B + + DECLARE + TYPE CONS (D3 : INTEGER := 1) IS + RECORD + C1 : REC (D3, F1); -- F1 EVALUATED + END RECORD; + CHK1 : BOOLEAN := CHK (F1_CONS, 1, "F1 NOT EVALUATED"); + X : CONS; -- F1 NOT EVALUATED AGAIN + Y : CONS; -- F1 NOT EVALUATED AGAIN + CHK2 : BOOLEAN := CHK (F1_CONS, 1, "F1 EVALUATED"); + BEGIN + IF X /= (1, (1, 1)) OR Y /= (1, (1, 1)) THEN + FAILED ("DISCRIMINANT VALUES NOT CORRECT"); + END IF; + END; + + F1_CONS := 12; + + DECLARE + TYPE CONS (D3 : INTEGER := 1) IS + RECORD + C1 : REC(D3, F1); + END RECORD; + BEGIN + BEGIN + DECLARE + X : CONS; + BEGIN + FAILED ("DISCRIMINANT CHECK NOT PERFORMED - 1"); + IF X /= (1, (1, 1)) THEN + COMMENT ("SHOULDN'T GET HERE"); + END IF; + END; + EXCEPTION + WHEN CONSTRAINT_ERROR => + NULL; + WHEN OTHERS => + FAILED ("UNEXPECTED EXCEPTION - 1"); + END; + + BEGIN + DECLARE + TYPE ACC_CONS IS ACCESS CONS; + X : ACC_CONS; + BEGIN + X := NEW CONS; + FAILED ("DISCRIMINANT CHECK NOT PERFORMED - 2"); + BEGIN + IF X.ALL /= (1, (1, 1)) THEN + COMMENT ("IRRELEVANT"); + END IF; + END; + EXCEPTION + WHEN CONSTRAINT_ERROR => + NULL; + WHEN OTHERS => + FAILED ("UNEXPECTED EXCEPTION RAISED - 2"); + END; + EXCEPTION + WHEN OTHERS => + FAILED ("CONSTRAINT CHECKED TOO SOON - 2"); + END; + + BEGIN + DECLARE + SUBTYPE SCONS IS CONS; + BEGIN + DECLARE + X : SCONS; + BEGIN + FAILED ("DISCRIMINANT CHECK NOT " & + "PERFORMED - 3"); + IF X /= (1, (1, 1)) THEN + COMMENT ("IRRELEVANT"); + END IF; + END; + EXCEPTION + WHEN CONSTRAINT_ERROR => + NULL; + WHEN OTHERS => + FAILED ("UNEXPECTED EXCEPTION RAISED - 3"); + END; + EXCEPTION + WHEN OTHERS => + FAILED ("CONSTRAINT CHECKED TOO SOON - 3"); + END; + + BEGIN + DECLARE + TYPE ARR IS ARRAY (1..5) OF CONS; + BEGIN + DECLARE + X : ARR; + BEGIN + FAILED ("DISCRIMINANT CHECK NOT " & + "PERFORMED - 4"); + IF X /= (1..5 => (1, (1, 1))) THEN + COMMENT ("IRRELEVANT"); + END IF; + END; + EXCEPTION + WHEN CONSTRAINT_ERROR => + NULL; + WHEN OTHERS => + FAILED ("UNEXPECTED EXCEPTION RAISED - 4"); + END; + EXCEPTION + WHEN OTHERS => + FAILED ("CONSTRAINT CHECKED TOO SOON - 4"); + END; + + BEGIN + DECLARE + TYPE NREC IS + RECORD + C1 : CONS; + END RECORD; + BEGIN + DECLARE + X : NREC; + BEGIN + FAILED ("DISCRIMINANT CHECK NOT " & + "PERFORMED - 5"); + IF X /= (C1 => (1, (1, 1))) THEN + COMMENT ("IRRELEVANT"); + END IF; + END; + EXCEPTION + WHEN CONSTRAINT_ERROR => + NULL; + WHEN OTHERS => + FAILED ("UNEXPECTED EXCEPTION RAISED - 5"); + END; + EXCEPTION + WHEN OTHERS => + FAILED ("CONSTRAINT CHECKED TOO SOON - 5"); + END; + + BEGIN + DECLARE + TYPE DREC IS NEW CONS; + BEGIN + DECLARE + X : DREC; + BEGIN + FAILED ("DISCRIMINANT CHECK NOT " & + "PERFORMED - 6"); + IF X /= (1, (1, 1)) THEN + COMMENT ("IRRELEVANT"); + END IF; + END; + EXCEPTION + WHEN CONSTRAINT_ERROR => + NULL; + WHEN OTHERS => + FAILED ("UNEXPECTED EXCEPTION RAISED - 6"); + END; + EXCEPTION + WHEN OTHERS => + FAILED ("CONSTRAINT CHECKED TOO SOON - 6"); + END; + + END; + + RESULT; + +EXCEPTION + WHEN OTHERS => + FAILED ("CONSTRAINT CHECK DONE TOO EARLY"); + RESULT; + +END C37213B; diff --git a/gcc-4.9/gcc/testsuite/ada/acats/tests/c3/c37213d.ada b/gcc-4.9/gcc/testsuite/ada/acats/tests/c3/c37213d.ada new file mode 100644 index 000000000..dc2d67299 --- /dev/null +++ b/gcc-4.9/gcc/testsuite/ada/acats/tests/c3/c37213d.ada @@ -0,0 +1,240 @@ +-- C37213D.ADA + +-- Grant of Unlimited Rights +-- +-- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687, +-- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained +-- unlimited rights in the software and documentation contained herein. +-- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making +-- this public release, the Government intends to confer upon all +-- recipients unlimited rights equal to those held by the Government. +-- These rights include rights to use, duplicate, release or disclose the +-- released technical data and computer software in whole or in part, in +-- any manner and for any purpose whatsoever, and to have or permit others +-- to do so. +-- +-- DISCLAIMER +-- +-- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR +-- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED +-- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF 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 +-- AN INDEX CONSTRAINT +-- DEPENDS ON A DISCRIMINANT, THE NON-DISCRIMINANT EXPRESSIONS IN THE +-- CONSTRAINT ARE EVALUATED WHEN THE COMPONENT SUBTYPE DEFINITION IS +-- ELABORATED, BUT THE VALUES ARE CHECKED WHEN THE RECORD TYPE IS: +-- +-- CASE B: USED WITHOUT A CONSTRAINT ONLY IN AN ALLOCATOR OR OBJECT +-- DECLARATION. + +-- JBG 10/17/86 + +WITH REPORT; USE REPORT; +PROCEDURE C37213D IS + + SUBTYPE SM IS INTEGER RANGE 1..10; + + TYPE MY_ARR IS ARRAY (SM RANGE <>) OF INTEGER; + + F1_CONS : INTEGER := 2; + + FUNCTION CHK ( + CONS : INTEGER; + VALUE : INTEGER; + MESSAGE : STRING) RETURN BOOLEAN IS + BEGIN + IF CONS /= VALUE THEN + FAILED (MESSAGE & ": CONS IS " & + INTEGER'IMAGE(CONS)); + END IF; + RETURN TRUE; + END CHK; + + FUNCTION F1 RETURN INTEGER IS + BEGIN + F1_CONS := F1_CONS - IDENT_INT(1); + RETURN F1_CONS; + END F1; + +BEGIN + TEST ("C37213D", "CHECK EVALUATION OF INDEX BOUNDS " & + "WHEN CONSTRAINT DEPENDS ON DISCRIMINANT, " & + "AND DISCRIMINANTS HAVE DEFAULTS"); + +-- CASE B + + DECLARE + TYPE CONS (D3 : INTEGER := 1) IS + RECORD + C1 : MY_ARR (F1..D3); -- F1 EVALUATED. + END RECORD; + CHK1 : BOOLEAN := CHK (F1_CONS, 1, "F1 NOT EVALUATED"); + X : CONS; -- F1 NOT EVALUATED AGAIN + Y : CONS; -- F1 NOT EVALUATED AGAIN + CHK2 : BOOLEAN := CHK (F1_CONS, 1, "F1 EVALUATED"); + BEGIN + IF X.C1'FIRST /= 1 OR Y.C1'LAST /= 1 THEN + FAILED ("INDEX BOUNDS NOT CORRECT"); + END IF; + END; + + F1_CONS := 12; + + DECLARE + TYPE CONS (D3 : INTEGER := 1) IS + RECORD + C1 : MY_ARR(D3..F1); + END RECORD; + BEGIN + BEGIN + DECLARE + X : CONS; + BEGIN + FAILED ("INDEX CHECK NOT PERFORMED - 1"); + IF X /= (1, (1, 1)) THEN + COMMENT ("SHOULDN'T GET HERE"); + END IF; + END; + EXCEPTION + WHEN CONSTRAINT_ERROR => + NULL; + WHEN OTHERS => + FAILED ("UNEXPECTED EXCEPTION - 1"); + END; + + BEGIN + DECLARE + TYPE ACC_CONS IS ACCESS CONS; + X : ACC_CONS; + BEGIN + X := NEW CONS; + FAILED ("INDEX CHECK NOT PERFORMED - 2"); + BEGIN + IF X.ALL /= (1, (1 => 1)) THEN + COMMENT ("IRRELEVANT"); + END IF; + END; + EXCEPTION + WHEN CONSTRAINT_ERROR => + NULL; + WHEN OTHERS => + FAILED ("UNEXPECTED EXCEPTION RAISED - 2"); + END; + EXCEPTION + WHEN OTHERS => + FAILED ("CONSTRAINT CHECKED TOO SOON - 2"); + END; + + BEGIN + DECLARE + SUBTYPE SCONS IS CONS; + BEGIN + DECLARE + X : SCONS; + BEGIN + FAILED ("INDEX CHECK NOT " & + "PERFORMED - 3"); + IF X /= (1, (1 => 1)) THEN + COMMENT ("IRRELEVANT"); + END IF; + END; + EXCEPTION + WHEN CONSTRAINT_ERROR => + NULL; + WHEN OTHERS => + FAILED ("UNEXPECTED EXCEPTION RAISED - 3"); + END; + EXCEPTION + WHEN OTHERS => + FAILED ("CONSTRAINT CHECKED TOO SOON - 3"); + END; + + BEGIN + DECLARE + TYPE ARR IS ARRAY (1..5) OF CONS; + BEGIN + DECLARE + X : ARR; + BEGIN + FAILED ("INDEX CHECK NOT " & + "PERFORMED - 4"); + IF X /= (1..5 => (1, (1 => 1))) THEN + COMMENT ("IRRELEVANT"); + END IF; + END; + EXCEPTION + WHEN CONSTRAINT_ERROR => + NULL; + WHEN OTHERS => + FAILED ("UNEXPECTED EXCEPTION RAISED - 4"); + END; + EXCEPTION + WHEN OTHERS => + FAILED ("CONSTRAINT CHECKED TOO SOON - 4"); + END; + + BEGIN + DECLARE + TYPE NREC IS + RECORD + C1 : CONS; + END RECORD; + BEGIN + DECLARE + X : NREC; + BEGIN + FAILED ("INDEX CHECK NOT " & + "PERFORMED - 5"); + IF X /= (C1 => (1, (1 => 1))) THEN + COMMENT ("IRRELEVANT"); + END IF; + END; + EXCEPTION + WHEN CONSTRAINT_ERROR => + NULL; + WHEN OTHERS => + FAILED ("UNEXPECTED EXCEPTION RAISED - 5"); + END; + EXCEPTION + WHEN OTHERS => + FAILED ("CONSTRAINT CHECKED TOO SOON - 5"); + END; + + BEGIN + DECLARE + TYPE DREC IS NEW CONS; + BEGIN + DECLARE + X : DREC; + BEGIN + FAILED ("INDEX CHECK NOT " & + "PERFORMED - 6"); + IF X /= (1, (1 => 1)) THEN + COMMENT ("IRRELEVANT"); + END IF; + END; + EXCEPTION + WHEN CONSTRAINT_ERROR => + NULL; + WHEN OTHERS => + FAILED ("UNEXPECTED EXCEPTION RAISED - 6"); + END; + EXCEPTION + WHEN OTHERS => + FAILED ("CONSTRAINT CHECKED TOO SOON - 6"); + END; + + END; + + RESULT; + +EXCEPTION + WHEN OTHERS => + FAILED ("CONSTRAINT CHECK DONE TOO EARLY"); + RESULT; + +END C37213D; diff --git a/gcc-4.9/gcc/testsuite/ada/acats/tests/c3/c37213f.ada b/gcc-4.9/gcc/testsuite/ada/acats/tests/c3/c37213f.ada new file mode 100644 index 000000000..3699c1a97 --- /dev/null +++ b/gcc-4.9/gcc/testsuite/ada/acats/tests/c3/c37213f.ada @@ -0,0 +1,379 @@ +-- C37213F.ADA + +-- Grant of Unlimited Rights +-- +-- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687, +-- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained +-- unlimited rights in the software and documentation contained herein. +-- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making +-- this public release, the Government intends to confer upon all +-- recipients unlimited rights equal to those held by the Government. +-- These rights include rights to use, duplicate, release or disclose the +-- released technical data and computer software in whole or in part, in +-- any manner and for any purpose whatsoever, and to have or permit others +-- to do so. +-- +-- DISCLAIMER +-- +-- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR +-- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED +-- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF 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 DISCRIMINANT CONSTRAINT +-- DEPENDS ON A DISCRIMINANT, THE NON-DISCRIMINANT EXPRESSIONS IN THE +-- CONSTRAINT ARE EVALUATED WHEN THE COMPONENT SUBTYPE DEFINITION IS +-- ELABORATED, BUT THE VALUES ARE CHECKED WHEN THE RECORD TYPE IS: +-- +-- CASE D: USED WITHOUT A CONSTRAINT ONLY IN AN ALLOCATOR OR OBJECT +-- DECLARATION AND THE COMPONENT IS PRESENT IN THE DEFAULT SUBTYPE. + +-- JBG 10/17/86 + +WITH REPORT; USE REPORT; +PROCEDURE C37213F IS + + SUBTYPE SM IS INTEGER RANGE 1..10; + + TYPE REC (D1, D2 : SM) IS + RECORD NULL; END RECORD; + + F1_CONS : INTEGER := 2; + + FUNCTION CHK ( + CONS : INTEGER; + VALUE : INTEGER; + MESSAGE : STRING) RETURN BOOLEAN IS + BEGIN + IF CONS /= VALUE THEN + FAILED (MESSAGE & ": CONS IS " & + INTEGER'IMAGE(CONS)); + END IF; + RETURN TRUE; + END CHK; + + FUNCTION F1 RETURN INTEGER IS + BEGIN + F1_CONS := F1_CONS - IDENT_INT(1); + RETURN F1_CONS; + END F1; + +BEGIN + TEST ("C37213F", "CHECK EVALUATION OF DISCRIMINANT EXPRESSIONS " & + "WHEN CONSTRAINT DEPENDS ON DISCRIMINANT, " & + "DISCRIMINANTS HAVE DEFAULTS, AND COMPONENT" & + "SUBTYPE DETERMINES WHETHER CONSTRAINT SHOULD " & + "BE CHECKED"); + +-- CASE D1: COMPONENT IS PRESENT + + DECLARE + TYPE CONS (D3 : INTEGER := IDENT_INT(1)) IS + RECORD + CASE D3 IS + WHEN -5..10 => + C1 : REC (D3, F1); -- F1 EVALUATED + WHEN OTHERS => + C2 : INTEGER := IDENT_INT(0); + END CASE; + END RECORD; + CHK1 : BOOLEAN := CHK (F1_CONS, 1, "F1 NOT EVALUATED"); + X : CONS; -- F1 NOT EVALUATED AGAIN + Y : CONS; -- F1 NOT EVALUATED AGAIN + CHK2 : BOOLEAN := CHK (F1_CONS, 1, "F1 EVALUATED"); + BEGIN + IF X /= (1, (1, 1)) OR Y /= (1, (1, 1)) THEN + FAILED ("DISCRIMINANT VALUES NOT CORRECT"); + END IF; + END; + + F1_CONS := 12; + + DECLARE + TYPE CONS (D3 : INTEGER := IDENT_INT(1)) IS + RECORD + CASE D3 IS + WHEN -5..10 => + C1 : REC(D3, F1); + WHEN OTHERS => + C2 : INTEGER := IDENT_INT(0); + END CASE; + END RECORD; + BEGIN + BEGIN + DECLARE + X : CONS; + BEGIN + FAILED ("DISCRIMINANT CHECK NOT PERFORMED - 1"); + IF X /= (1, (1, 1)) THEN + COMMENT ("SHOULDN'T GET HERE"); + END IF; + END; + EXCEPTION + WHEN CONSTRAINT_ERROR => + NULL; + WHEN OTHERS => + FAILED ("UNEXPECTED EXCEPTION - 1"); + END; + + BEGIN + DECLARE + TYPE ACC_CONS IS ACCESS CONS; + X : ACC_CONS; + BEGIN + X := NEW CONS; + FAILED ("DISCRIMINANT CHECK NOT PERFORMED - 2"); + IF X.ALL /= (1, (1, 1)) THEN + COMMENT ("IRRELEVANT"); + END IF; + EXCEPTION + WHEN CONSTRAINT_ERROR => + NULL; + WHEN OTHERS => + FAILED ("UNEXPECTED EXCEPTION RAISED - 2A"); + END; + EXCEPTION + WHEN OTHERS => + FAILED ("UNEXPECTED EXCEPTION RAISED - 2B"); + END; + + BEGIN + DECLARE + SUBTYPE SCONS IS CONS; + BEGIN + DECLARE + X : SCONS; + BEGIN + FAILED ("DISCRIMINANT CHECK NOT " & + "PERFORMED - 3"); + IF X /= (1, (1, 1)) THEN + COMMENT ("IRRELEVANT"); + END IF; + END; + EXCEPTION + WHEN CONSTRAINT_ERROR => + NULL; + WHEN OTHERS => + FAILED ("UNEXPECTED EXCEPTION RAISED - 3"); + END; + EXCEPTION + WHEN OTHERS => + FAILED ("CONSTRAINT CHECKED TOO SOON - 3"); + END; + + BEGIN + DECLARE + TYPE ARR IS ARRAY (1..5) OF CONS; + BEGIN + DECLARE + X : ARR; + BEGIN + FAILED ("DISCRIMINANT CHECK NOT " & + "PERFORMED - 4"); + IF X /= (1..5 => (1, (1, 1))) THEN + COMMENT ("IRRELEVANT"); + END IF; + END; + EXCEPTION + WHEN CONSTRAINT_ERROR => + NULL; + WHEN OTHERS => + FAILED ("UNEXPECTED EXCEPTION RAISED - 4"); + END; + EXCEPTION + WHEN OTHERS => + FAILED ("CONSTRAINT CHECKED TOO SOON - 4"); + END; + + BEGIN + DECLARE + TYPE NREC IS + RECORD + C1 : CONS; + END RECORD; + BEGIN + DECLARE + X : NREC; + BEGIN + FAILED ("DISCRIMINANT CHECK NOT " & + "PERFORMED - 5"); + IF X /= (C1 => (1, (1, 1))) THEN + COMMENT ("IRRELEVANT"); + END IF; + END; + EXCEPTION + WHEN CONSTRAINT_ERROR => + NULL; + WHEN OTHERS => + FAILED ("UNEXPECTED EXCEPTION RAISED - 5"); + END; + EXCEPTION + WHEN OTHERS => + FAILED ("CONSTRAINT CHECKED TOO SOON - 5"); + END; + + BEGIN + DECLARE + TYPE DREC IS NEW CONS; + BEGIN + DECLARE + X : DREC; + BEGIN + FAILED ("DISCRIMINANT CHECK NOT " & + "PERFORMED - 6"); + IF X /= (1, (1, 1)) THEN + COMMENT ("IRRELEVANT"); + END IF; + END; + EXCEPTION + WHEN CONSTRAINT_ERROR => + NULL; + WHEN OTHERS => + FAILED ("UNEXPECTED EXCEPTION RAISED - 6"); + END; + EXCEPTION + WHEN OTHERS => + FAILED ("CONSTRAINT CHECKED TOO SOON - 6"); + END; + + END; + +-- CASE C2 : COMPONENT IS ABSENT + + F1_CONS := 2; + + DECLARE + TYPE CONS (D3 : INTEGER := IDENT_INT(-6)) IS + RECORD + CASE D3 IS + WHEN -5..10 => + C1 : REC (D3, F1); -- F1 EVALUATED + WHEN OTHERS => + C2 : INTEGER := IDENT_INT(0); + END CASE; + END RECORD; + CHK1 : BOOLEAN := CHK (F1_CONS, 1, "F1 NOT EVALUATED - 2"); + X : CONS; -- F1 NOT EVALUATED AGAIN + Y : CONS; -- F1 NOT EVALUATED AGAIN + CHK2 : BOOLEAN := CHK (F1_CONS, 1, "F1 EVALUATED - 2"); + BEGIN + IF X /= (-6, 0) OR Y /= (-6, 0) THEN + FAILED ("DISCRIMINANT VALUES NOT CORRECT"); + END IF; + END; + + F1_CONS := 12; + + DECLARE + TYPE CONS (D3 : INTEGER := IDENT_INT(11)) IS + RECORD + CASE D3 IS + WHEN -5..10 => + C1 : REC(D3, F1); + WHEN OTHERS => + C2 : INTEGER := IDENT_INT(0); + END CASE; + END RECORD; + BEGIN + BEGIN + DECLARE + X : CONS; + BEGIN + IF X /= (11, 0) THEN + FAILED ("WRONG VALUE FOR X - 11"); + END IF; + END; + EXCEPTION + WHEN OTHERS => + FAILED ("NONEXISTENT CONSTRAINT CHECKED - 11"); + END; + + BEGIN + DECLARE + SUBTYPE SCONS IS CONS; + BEGIN + DECLARE + X : SCONS; + BEGIN + IF X /= (11, 0) THEN + FAILED ("X VALUE WRONG - 12"); + END IF; + END; + END; + EXCEPTION + WHEN OTHERS => + FAILED ("NONEXISTENT CONSTRAINT CHECKED - 12"); + END; + + BEGIN + DECLARE + TYPE ARR IS ARRAY (1..5) OF CONS; + X : ARR; + BEGIN + IF X /= (1..5 => (11, 0)) THEN + FAILED ("X VALUE INCORRECT - 13"); + END IF; + END; + EXCEPTION + WHEN OTHERS => + FAILED ("NONEXISTENT CONSTRAINT CHECKED - 13"); + END; + + BEGIN + DECLARE + TYPE NREC IS + RECORD + C1 : CONS; + END RECORD; + X : NREC; + BEGIN + IF X /= (C1 => (11, 0)) THEN + FAILED ("X VALUE IS INCORRECT - 14"); + END IF; + END; + EXCEPTION + WHEN OTHERS => + FAILED ("NONEXISTENT CONSTRAINT CHECKED - 14"); + END; + + BEGIN + DECLARE + TYPE NREC IS NEW CONS; + X : NREC; + BEGIN + IF X /= (11, 0) THEN + FAILED ("X VALUE INCORRECT - 15"); + END IF; + END; + EXCEPTION + WHEN OTHERS => + FAILED ("NONEXISTENT CONSTRAINT CHECKED - 15"); + END; + + BEGIN + DECLARE + TYPE ACC_CONS IS ACCESS CONS; + X : ACC_CONS := NEW CONS; + BEGIN + IF X.ALL /= (11, 0) THEN + FAILED ("X VALUE INCORRECT - 17"); + END IF; + END; + EXCEPTION + WHEN OTHERS => + FAILED ("NONEXISTENT CONSTRAINT CHECKED - 17"); + END; + END; + + + RESULT; + +EXCEPTION + WHEN OTHERS => + FAILED ("CONSTRAINT CHECK DONE TOO EARLY"); + RESULT; + +END C37213F; diff --git a/gcc-4.9/gcc/testsuite/ada/acats/tests/c3/c37213h.ada b/gcc-4.9/gcc/testsuite/ada/acats/tests/c3/c37213h.ada new file mode 100644 index 000000000..e83ae07ca --- /dev/null +++ b/gcc-4.9/gcc/testsuite/ada/acats/tests/c3/c37213h.ada @@ -0,0 +1,457 @@ +-- C37213H.ADA + +-- Grant of Unlimited Rights +-- +-- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687, +-- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained +-- unlimited rights in the software and documentation contained herein. +-- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making +-- this public release, the Government intends to confer upon all +-- recipients unlimited rights equal to those held by the Government. +-- These rights include rights to use, duplicate, release or disclose the +-- released technical data and computer software in whole or in part, in +-- any manner and for any purpose whatsoever, and to have or permit others +-- to do so. +-- +-- DISCLAIMER +-- +-- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR +-- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED +-- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF 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, WHERE AN INDEX CONSTRAINT DEPENDS ON A RECORD +-- DISCRIMINANT WITH A DEFAULT VALUE AND THE RECORD TYPE IS NOT +-- EXPLICITLY CONSTRAINED, THAT THE NON-DISCRIMINANT EXPRESSIONS +-- IN THE INDEX CONSTRAINT ARE: +-- 1) EVALUATED WHEN THE RECORD COMPONENT SUBTYPE DEFINITION +-- IS ELABORATED, +-- 2) PROPERLY CHECKED FOR COMPATIBILITY ONLY IN AN ALLOCATION +-- OR OBJECT DECLARATION AND ONLY IF THE DISCRIMINANT- +-- DEPENDENT COMPONENT IS PRESENT IN THE SUBTYPE. + +-- HISTORY: +-- JBG 10/17/86 CREATED ORIGINAL TEST. +-- VCL 10/23/87 MODIFIED THIS HEADER; MODIFIED THE CHECK OF +-- SUBTYPE 'SCONS', IN BOTH SUBPARTS OF THE TEST, +-- TO INDICATE FAILURE IF CONSTRAINT_ERROR IS RAISED +-- FOR THE SUBTYPE DECLARATION AND FAILURE IF +-- CONSTRAINT_ERROR IS NOT RAISED FOR AN OBJECT +-- DECLARATION OF THIS SUBTYPE; RELOCATED THE CALL TO +-- REPORT.TEST SO THAT IT COMES BEFORE ANY +-- DECLARATIONS; ADDED 'SEQUENCE_NUMBER' TO IDENTIFY +-- THE CURRENT SUBTEST (FOR EXCEPTIONS); CHANGE THE +-- TYPE OF THE DISCRIMINANT IN THE RECORD 'CONS' +-- TO AN INTEGER SUBTYPE. +-- VCL 03/30/88 MODIFIED HEADER AND MESSAGES OUTPUT BY REPORT +-- PACKAGE. + +WITH REPORT; USE REPORT; +PROCEDURE C37213H IS +BEGIN + TEST ("C37213H", "THE NON-DISCRIMINANT EXPRESSIONS OF AN " & + "INDEX CONSTRAINT THAT DEPEND ON A " & + "DISCRIMINANT WITH A DEFAULT VALUE ARE " & + "PROPERLY EVALUATED AND CHECKED WHEN THE " & + "RECORD TYPE IS NOT EXPLICITLY CONSTRAINED AND " & + "THE COMPONENT IS AND IS NOT PRESENT IN THE " & + "SUBTYPE"); + + DECLARE + SEQUENCE_NUMBER : INTEGER; + + SUBTYPE DISCR IS INTEGER RANGE -50..50; + SUBTYPE SM IS INTEGER RANGE 1..10; + TYPE MY_ARR IS ARRAY (SM RANGE <>) OF INTEGER; + + F1_CONS : INTEGER := 2; + + FUNCTION CHK ( + CONS : INTEGER; + VALUE : INTEGER; + MESSAGE : STRING) RETURN BOOLEAN IS + BEGIN + IF CONS /= VALUE THEN + FAILED (MESSAGE & ": F1_CONS IS " & + INTEGER'IMAGE(F1_CONS)); + END IF; + RETURN TRUE; + END CHK; + + FUNCTION F1 RETURN INTEGER IS + BEGIN + F1_CONS := F1_CONS - IDENT_INT(1); + RETURN F1_CONS; + END F1; + BEGIN + + +-- CASE 1: DISCRIMINANT-DEPENDENT COMPONENT IS PRESENT. + + SEQUENCE_NUMBER :=1; + DECLARE + TYPE CONS (D3 : DISCR := IDENT_INT(1)) IS + RECORD + CASE D3 IS + WHEN -5..10 => + C1 : MY_ARR(F1..D3); -- F1 EVALUATED. + WHEN OTHERS => + C2 : INTEGER := IDENT_INT(0); + END CASE; + END RECORD; + + CHK1 : BOOLEAN := CHK (F1_CONS, 1, "F1 NOT EVALUATED"); + + X : CONS; -- F1 NOT EVALUATED AGAIN. + Y : CONS; -- F1 NOT EVALUATED AGAIN. + + CHK2 : BOOLEAN := CHK (F1_CONS, 1, "F1 EVALUATED"); + BEGIN + IF X.C1'FIRST /= 1 OR Y.C1'LAST /= 1 THEN + FAILED ("VALUES NOT CORRECT"); + END IF; + END; + + + F1_CONS := 12; + + SEQUENCE_NUMBER := 2; + DECLARE + TYPE CONS (D3 : DISCR := IDENT_INT(1)) IS + RECORD + CASE D3 IS + WHEN -5..10 => + C1 : MY_ARR(D3..F1); + WHEN OTHERS => + C2 : INTEGER := IDENT_INT(0); + END CASE; + END RECORD; + BEGIN + BEGIN + DECLARE + X : CONS; + BEGIN + FAILED ("INDEX CHECK NOT PERFORMED - 1"); + IF X /= (1, (1, 1)) THEN + COMMENT ("INCORRECT VALUES FOR X - 1"); + END IF; + END; + EXCEPTION + WHEN CONSTRAINT_ERROR => + NULL; + WHEN OTHERS => + FAILED ("UNEXPECTED EXCEPTION RAISED - 1"); + END; + + BEGIN + DECLARE + SUBTYPE SCONS IS CONS; + BEGIN + DECLARE + X : SCONS; + BEGIN + FAILED ("INDEX CHECK NOT PERFORMED - 2"); + IF X /= (1, (1, 1)) THEN + COMMENT ("INCORRECT VALUES FOR X " & + "- 2"); + END IF; + END; + EXCEPTION + WHEN CONSTRAINT_ERROR => + NULL; + WHEN OTHERS => + FAILED ("UNEXPECTED EXCEPTION RAISED " & + "- 2A"); + END; + EXCEPTION + WHEN OTHERS => + FAILED ("UNEXPECTED EXCEPTION RAISED - 2B"); + END; + + BEGIN + DECLARE + TYPE ARR IS ARRAY (1..5) OF CONS; + BEGIN + DECLARE + X : ARR; + BEGIN + FAILED ("INDEX CHECK NOT PERFORMED - 3"); + IF X /= (1..5 => (1, (1, 1))) THEN + COMMENT ("INCORRECT VALUES FOR X " & + "- 3"); + END IF; + END; + EXCEPTION + WHEN CONSTRAINT_ERROR => + NULL; + WHEN OTHERS => + FAILED ("UNEXPECTED EXCEPTION RAISED " & + "- 3A"); + END; + EXCEPTION + WHEN OTHERS => + FAILED ("UNEXPECTED EXCEPTION RAISED - 3B"); + END; + + BEGIN + DECLARE + TYPE NREC IS + RECORD + C1 : CONS; + END RECORD; + BEGIN + DECLARE + X : NREC; + BEGIN + FAILED ("INDEX CHECK NOT PERFORMED - 4"); + IF X /= (C1 => (1, (1, 1))) THEN + COMMENT ("INCORRECT VALUES FOR X " & + "- 4"); + END IF; + END; + EXCEPTION + WHEN CONSTRAINT_ERROR => + NULL; + WHEN OTHERS => + FAILED ("UNEXPECTED EXCEPTION RAISED " & + "- 4A"); + END; + EXCEPTION + WHEN OTHERS => + FAILED ("UNEXPECTED EXCEPTION RAISED - 4B"); + END; + + BEGIN + DECLARE + TYPE NREC IS NEW CONS; + BEGIN + DECLARE + X : NREC; + BEGIN + FAILED ("INDEX CHECK NOT PERFORMED - 5"); + IF X /= (1, (1, 1)) THEN + COMMENT ("INCORRECT VALUES FOR X " & + "- 5"); + END IF; + END; + EXCEPTION + WHEN CONSTRAINT_ERROR => + NULL; + WHEN OTHERS => + FAILED ("UNEXPECTED EXCEPTION RAISED " & + "- 5A"); + END; + EXCEPTION + WHEN OTHERS => + FAILED ("UNEXPECTED EXCEPTION RAISED - 5B"); + END; + + BEGIN + DECLARE + TYPE ACC_CONS IS ACCESS CONS; + BEGIN + DECLARE + X : ACC_CONS; + BEGIN + X := NEW CONS; + FAILED ("INDEX CHECK NOT PERFORMED - 6"); + IF X.ALL /= (1, (1, 1)) THEN + COMMENT ("INCORRECT VALUES FOR X " & + "- 6"); + END IF; + EXCEPTION + WHEN CONSTRAINT_ERROR => + NULL; + WHEN OTHERS => + COMMENT ("UNEXPECTED EXCEPTION " & + "RAISED - 6A"); + END; + EXCEPTION + WHEN OTHERS => + COMMENT ("UNEXPECTED EXCEPTION RAISED " & + "- 6B"); + END; + EXCEPTION + WHEN OTHERS => + FAILED ("UNEXPECTED EXCEPTION RAISED - 6C"); + END; + END; + + +-- CASE D2: DISCRIMINANT-DEPENDENT COMPONENT IS ABSENT. + + F1_CONS := 2; + + SEQUENCE_NUMBER := 3; + DECLARE + TYPE CONS (D3 : DISCR := IDENT_INT(-6)) IS + RECORD + CASE D3 IS + WHEN -5..10 => + C1 : MY_ARR(D3..F1); -- F1 EVALUATED. + WHEN OTHERS => + C2 : INTEGER := IDENT_INT(0); + END CASE; + END RECORD; + CHK1 : BOOLEAN := CHK (F1_CONS, 1, "F1 NOT EVALUATED"); + + X : CONS; -- F1 NOT EVALUATED AGAIN. + Y : CONS; -- F1 NOT EVALUATED AGAIN. + + CHK2 : BOOLEAN := CHK (F1_CONS, 1, "F1 EVALUATED"); + BEGIN + IF X /= (-6, 0) OR Y /= (-6, 0) THEN + FAILED ("VALUES NOT CORRECT"); + END IF; + END; + + F1_CONS := 12; + + SEQUENCE_NUMBER := 4; + DECLARE + TYPE CONS (D3 : DISCR := IDENT_INT(11)) IS + RECORD + CASE D3 IS + WHEN -5..10 => + C1 : MY_ARR(D3..F1); + WHEN OTHERS => + C2 : INTEGER := IDENT_INT(0); + END CASE; + END RECORD; + BEGIN + BEGIN + DECLARE + X : CONS; + BEGIN + IF X /= (11, 0) THEN + FAILED ("X VALUE IS INCORRECT - 11"); + END IF; + END; + EXCEPTION + WHEN OTHERS => + FAILED ("UNEXPECTED EXCEPTION RAISED - 11"); + END; + + BEGIN + DECLARE + SUBTYPE SCONS IS CONS; + BEGIN + DECLARE + X : SCONS; + BEGIN + IF X /= (11, 0) THEN + FAILED ("X VALUE INCORRECT - 12"); + END IF; + END; + EXCEPTION + WHEN OTHERS => + FAILED ("UNEXPECTED EXCEPTION RAISED - " & + "12A"); + END; + EXCEPTION + WHEN OTHERS => + FAILED ("UNEXPECTED EXCEPTION RAISED - 12B"); + END; + + BEGIN + DECLARE + TYPE ARR IS ARRAY (1..5) OF CONS; + BEGIN + DECLARE + X : ARR; + BEGIN + IF X /= (1..5 => (11, 0)) THEN + FAILED ("X VALUE INCORRECT - 13"); + END IF; + END; + EXCEPTION + WHEN OTHERS => + FAILED ("UNEXPECTED EXCEPTION RAISED - " & + "13A"); + END; + EXCEPTION + WHEN OTHERS => + FAILED ("UNEXPECTED EXCEPTION RAISED - 13B"); + END; + + BEGIN + DECLARE + TYPE NREC IS + RECORD + C1 : CONS; + END RECORD; + BEGIN + DECLARE + X : NREC; + BEGIN + IF X /= (C1 => (11, 0)) THEN + FAILED ("X VALUE INCORRECT - 14"); + END IF; + END; + EXCEPTION + WHEN OTHERS => + FAILED ("UNEXPECTED EXCEPTION RAISED - " & + "14A"); + END; + EXCEPTION + WHEN OTHERS => + FAILED ("UNEXPECTED EXCEPTION RAISED - 14B"); + END; + + BEGIN + DECLARE + TYPE NREC IS NEW CONS; + BEGIN + DECLARE + X : NREC; + BEGIN + IF X /= (11, 0) THEN + FAILED ("X VALUE INCORRECT - 15"); + END IF; + END; + EXCEPTION + WHEN CONSTRAINT_ERROR => + NULL; + WHEN OTHERS => + FAILED ("UNEXPECTED EXCEPTION RAISED - " & + "15A"); + END; + EXCEPTION + WHEN OTHERS => + FAILED ("UNEXPECTED EXCEPTION RAISED - 15B"); + END; + + BEGIN + DECLARE + TYPE ACC_CONS IS ACCESS CONS; + X : ACC_CONS; + BEGIN + X := NEW CONS; + IF X.ALL /= (11, 0) THEN + FAILED ("X VALUE INCORRECT - 17"); + END IF; + EXCEPTION + WHEN OTHERS => + FAILED ("UNEXPECTED EXCEPTION RAISED - " & + "17A"); + END; + EXCEPTION + WHEN OTHERS => + FAILED ("UNEXPECTED EXCEPTION RAISED - 17B"); + END; + END; + + EXCEPTION + WHEN CONSTRAINT_ERROR => + FAILED ("INDEX VALUES IMPROPERLY CHECKED - " & + INTEGER'IMAGE (SEQUENCE_NUMBER)); + WHEN OTHERS => + FAILED ("UNEXPECTED EXCEPTION RAISED " & + INTEGER'IMAGE (SEQUENCE_NUMBER)); + END; + + RESULT; +END C37213H; diff --git a/gcc-4.9/gcc/testsuite/ada/acats/tests/c3/c37213j.ada b/gcc-4.9/gcc/testsuite/ada/acats/tests/c3/c37213j.ada new file mode 100644 index 000000000..f09d853c2 --- /dev/null +++ b/gcc-4.9/gcc/testsuite/ada/acats/tests/c3/c37213j.ada @@ -0,0 +1,320 @@ +-- C37213J.ADA + +-- Grant of Unlimited Rights +-- +-- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687, +-- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained +-- unlimited rights in the software and documentation contained herein. +-- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making +-- this public release, the Government intends to confer upon all +-- recipients unlimited rights equal to those held by the Government. +-- These rights include rights to use, duplicate, release or disclose the +-- released technical data and computer software in whole or in part, in +-- any manner and for any purpose whatsoever, and to have or permit others +-- to do so. +-- +-- DISCLAIMER +-- +-- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR +-- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED +-- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE +-- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE +-- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A +-- PARTICULAR PURPOSE OF SAID MATERIAL. +--* +-- OBJECTIVE: +-- CHECK, FOR A GENERIC FORMAL TYPE - WHERE A DISCRIMINANT OR AN +-- INDEX CONSTRAINT DEPENDS ON A RECORD DISCRIMINANT AND THE +-- RECORD TYPE IS CONSTRAINED BY DEFAULT - USED TO DECLARE AN +-- OBJECT OR A SUBTYPE, THAT THE NON-DISCRIMINANT EXPRESSIONS +-- OF THE CONSTRAINT ARE CHECKED FOR COMPATIBILITY: +-- 1) ONLY IN AN OBJECT DECLARATION, AND +-- 2) ONLY IF THE DISCRIMINANT-DEPENDENT COMPONENT IS PRESENT +-- IN THE SUBTYPE. + +-- HISTORY: +-- JBG 10/17/86 CREATED ORIGINAL TEST. +-- VCL 10/23/87 MODIFIED THIS HEADER; SEPARATED THIS TEST INTO +-- 3 NEW TESTS (J,K,L); CHANGED THE AGGREGATE FOR +-- THE PARAMETER 'VALUE' IN THE CALL OF PROCEDURE +-- 'SUBTYPE_CHK1'; MOVED THE CALL TO REPORT.TEST +-- SO THAT IT COMES BEFORE ANY DECLARATIONS; ADDED +-- A SEQUENCE COUNTER TO IDENTIFY WHICH SUBTEST +-- DECLARATION PART RAISES CONSTRAINT_ERROR. +-- VCL 03/28/88 MODIFIED THE TEST DISCRIPTION TO MORE ACCURATELY +-- DESCRIBE THE OBJECTIVE; CHANGED THE FORMAL +-- PARAMETERS TO THE GENERIC UNITS AND THE +-- CORRESPONDING ACTUAL PARAMETERS; REORGANIZED THE +-- TEST SO THAT ALL OPERATIONS ON A SPECIFIC TYPE +-- ARE TOGETHER. + +WITH REPORT; USE REPORT; +PROCEDURE C37213J IS +BEGIN + TEST ("C37213J", "THE NON-DISCRIMINANT VALUES OF A DISCRIMINANT " & + "OR AN INDEX CONSTRAINT THAT DEPEND ON A " & + "DISCRIMINANT ARE PROPERLY CHECKED WHEN THE " & + "RECORD TYPE IS CONSTRAINED BY DEFAULT AND " & + "USED AS THE ACTUAL PARAMETER TO A GENERIC " & + "FORMAL TYPE USED TO DECLARE AN OBJECT OR A " & + "SUBTYPE"); + + DECLARE + SUBTYPE SM IS INTEGER RANGE 1..10; + TYPE REC (D1, D2 : SM) IS + RECORD NULL; END RECORD; + TYPE MY_ARR IS ARRAY (SM RANGE <>) OF INTEGER; + + SEQUENCE_NUMBER : INTEGER; + + GENERIC + TYPE CONS IS PRIVATE; + OBJ_XCP : BOOLEAN; + TAG : STRING; + PACKAGE OBJ_CHK IS END OBJ_CHK; + + GENERIC + TYPE CONS IS PRIVATE; + PROCEDURE SUBTYP_CHK (OBJ_XCP : BOOLEAN; + TAG : STRING); + + PACKAGE BODY OBJ_CHK IS + BEGIN -- DECLARE AN OBJECT OF THE FORMAL TYPE. + DECLARE + X : CONS; + + FUNCTION VALUE RETURN CONS IS + BEGIN + IF EQUAL (3,3) THEN + RETURN X; + ELSE + RETURN X; + END IF; + END VALUE; + BEGIN + IF OBJ_XCP THEN + FAILED ("NO CHECK DURING DECLARATION " & + "OF OBJECT OF TYPE CONS - " & TAG); + ELSIF X /= VALUE THEN + FAILED ("INCORRECT VALUE FOR OBJECT OF " & + "TYPE CONS - " & TAG); + END IF; + END; + EXCEPTION + WHEN CONSTRAINT_ERROR => + IF NOT OBJ_XCP THEN + FAILED ("IMPROPER CONSTRAINT CHECKED " & + "DURING DECLARATION OF OBJECT " & + "OF TYPE CONS - " & TAG); + END IF; + END OBJ_CHK; + + PROCEDURE SUBTYP_CHK (OBJ_XCP : BOOLEAN; + TAG : STRING) IS + BEGIN -- DECLARE A SUBTYPE OF THE FORMAL TYPE. + DECLARE + SUBTYPE SCONS IS CONS; + BEGIN + DECLARE + X : SCONS; + + FUNCTION VALUE RETURN SCONS IS + BEGIN + IF EQUAL (5, 5) THEN + RETURN X; + ELSE + RETURN X; + END IF; + END VALUE; + BEGIN + IF OBJ_XCP THEN + FAILED ("NO CHECK DURING DECLARATION " & + "OF OBJECT OF SUBTYPE SCONS - " & + TAG); + ELSIF X /= VALUE THEN + FAILED ("INCORRECT VALUE FOR OBJECT " & + "OF SUBTYPE SCONS - " & TAG); + END IF; + END; + EXCEPTION + WHEN CONSTRAINT_ERROR => + IF NOT OBJ_XCP THEN + FAILED ("IMPROPER CONSTRAINT CHECKED " & + "DURING DECLARATION OF OBJECT " & + "OF SUBTYPE SCONS - " & TAG); + END IF; + END; + EXCEPTION + WHEN CONSTRAINT_ERROR => + FAILED ("CONSTRAINT IMPROPERLY CHECKED " & + "DURING SUBTYPE DECLARATION - " & TAG); + END SUBTYP_CHK; + BEGIN + SEQUENCE_NUMBER := 1; + DECLARE + TYPE REC_DEF (D3 : INTEGER := 1) IS + RECORD + C1 : REC (D3, 0); + END RECORD; + + PACKAGE PACK1 IS NEW OBJ_CHK (REC_DEF, + OBJ_XCP => TRUE, + TAG => "PACK1"); + + PROCEDURE PROC1 IS NEW SUBTYP_CHK (REC_DEF); + BEGIN + PROC1 (OBJ_XCP => TRUE, TAG => "PROC1"); + END; + + SEQUENCE_NUMBER := 2; + DECLARE + TYPE ARR_DEF (D3 : INTEGER := IDENT_INT(1)) IS + RECORD + C1 : MY_ARR (0..D3); + END RECORD; + + PACKAGE PACK2 IS NEW OBJ_CHK (ARR_DEF, + OBJ_XCP => TRUE, + TAG => "PACK2"); + + PROCEDURE PROC2 IS NEW SUBTYP_CHK (ARR_DEF); + BEGIN + PROC2 (OBJ_XCP => TRUE, TAG => "PROC2"); + END; + + + SEQUENCE_NUMBER := 3; + DECLARE + TYPE VAR_REC_DEF1 (D3 : INTEGER := 1) IS + RECORD + CASE D3 IS + WHEN -5..10 => + C1 : REC (D3, IDENT_INT(11)); + WHEN OTHERS => + C2 : INTEGER := IDENT_INT(5); + END CASE; + END RECORD; + + PACKAGE PACK3 IS NEW OBJ_CHK (VAR_REC_DEF1, + OBJ_XCP => TRUE, + TAG => "PACK3"); + + PROCEDURE PROC3 IS NEW SUBTYP_CHK (VAR_REC_DEF1); + BEGIN + PROC3 (OBJ_XCP => TRUE, TAG => "PROC3"); + END; + + SEQUENCE_NUMBER := 4; + DECLARE + TYPE VAR_REC_DEF6 (D3 : INTEGER := IDENT_INT(-6)) IS + RECORD + CASE D3 IS + WHEN -5..10 => + C1 : REC (D3, IDENT_INT(11)); + WHEN OTHERS => + C2 : INTEGER := IDENT_INT(5); + END CASE; + END RECORD; + + PACKAGE PACK4 IS NEW OBJ_CHK (VAR_REC_DEF6, + OBJ_XCP => FALSE, + TAG => "PACK4"); + + PROCEDURE PROC4 IS NEW SUBTYP_CHK (VAR_REC_DEF6); + BEGIN + PROC4 (OBJ_XCP => FALSE,TAG => "PROC4"); + END; + + SEQUENCE_NUMBER := 5; + DECLARE + TYPE VAR_REC_DEF11 (D3 : INTEGER := 11) IS + RECORD + CASE D3 IS + WHEN -5..10 => + C1 : REC (D3, IDENT_INT(11)); + WHEN OTHERS => + C2 : INTEGER := IDENT_INT(5); + END CASE; + END RECORD; + + PACKAGE PACK5 IS NEW OBJ_CHK (VAR_REC_DEF11, + OBJ_XCP => FALSE, + TAG => "PACK5"); + + PROCEDURE PROC5 IS NEW SUBTYP_CHK (VAR_REC_DEF11); + BEGIN + PROC5 (OBJ_XCP => FALSE, TAG => "PROC5"); + END; + + SEQUENCE_NUMBER := 6; + DECLARE + TYPE VAR_ARR_DEF1 (D3 : INTEGER := IDENT_INT(1)) IS + RECORD + CASE D3 IS + WHEN -5..10 => + C1 : MY_ARR(D3..IDENT_INT(11)); + WHEN OTHERS => + C2 : INTEGER := IDENT_INT(5); + END CASE; + END RECORD; + + PACKAGE PACK6 IS NEW OBJ_CHK (VAR_ARR_DEF1, + OBJ_XCP => TRUE, + TAG => "PACK6"); + + PROCEDURE PROC6 IS NEW SUBTYP_CHK (VAR_ARR_DEF1); + BEGIN + PROC6 (OBJ_XCP => TRUE, TAG => "PROC6"); + END; + + SEQUENCE_NUMBER := 7; + DECLARE + TYPE VAR_ARR_DEF6 (D3 : INTEGER := -6) IS + RECORD + CASE D3 IS + WHEN -5..10 => + C1 : MY_ARR(D3..IDENT_INT(11)); + WHEN OTHERS => + C2 : INTEGER := IDENT_INT(5); + END CASE; + END RECORD; + + PACKAGE PACK7 IS NEW OBJ_CHK (VAR_ARR_DEF6, + OBJ_XCP => FALSE, + TAG => "PACK7"); + + PROCEDURE PROC7 IS NEW SUBTYP_CHK (VAR_ARR_DEF6); + BEGIN + PROC7 (OBJ_XCP => FALSE, TAG => "PROC7"); + END; + + SEQUENCE_NUMBER := 8; + DECLARE + TYPE VAR_ARR_DEF11 (D3 : INTEGER := IDENT_INT(11)) IS + RECORD + CASE D3 IS + WHEN -5..10 => + C1 : MY_ARR(D3..IDENT_INT(11)); + WHEN OTHERS => + C2 : INTEGER := IDENT_INT(5); + END CASE; + END RECORD; + + PACKAGE PACK8 IS NEW OBJ_CHK (VAR_ARR_DEF11, + OBJ_XCP => FALSE, + TAG => "PACK8"); + + PROCEDURE PROC8 IS NEW SUBTYP_CHK (VAR_ARR_DEF11); + BEGIN + PROC8 (OBJ_XCP => FALSE, TAG => "PROC8"); + END; + + EXCEPTION + WHEN OTHERS => + FAILED ("EXCEPTION RAISED DURING DECLARATION / " & + "INSTANTIATION ELABORATION - " & + INTEGER'IMAGE(SEQUENCE_NUMBER)); + END; + + RESULT; +END C37213J; diff --git a/gcc-4.9/gcc/testsuite/ada/acats/tests/c3/c37213k.ada b/gcc-4.9/gcc/testsuite/ada/acats/tests/c3/c37213k.ada new file mode 100644 index 000000000..d5b5dc38d --- /dev/null +++ b/gcc-4.9/gcc/testsuite/ada/acats/tests/c3/c37213k.ada @@ -0,0 +1,324 @@ +-- C37213K.ADA + +-- Grant of Unlimited Rights +-- +-- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687, +-- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained +-- unlimited rights in the software and documentation contained herein. +-- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making +-- this public release, the Government intends to confer upon all +-- recipients unlimited rights equal to those held by the Government. +-- These rights include rights to use, duplicate, release or disclose the +-- released technical data and computer software in whole or in part, in +-- any manner and for any purpose whatsoever, and to have or permit others +-- to do so. +-- +-- DISCLAIMER +-- +-- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR +-- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED +-- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE +-- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE +-- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A +-- PARTICULAR PURPOSE OF SAID MATERIAL. +--* +-- OBJECTIVE: +-- CHECK, FOR A GENERIC FORMAL TYPE - WHERE A DISCRIMINANT OR AN +-- INDEX CONSTRAINT DEPENDS ON A RECORD DISCRIMINANT AND THE +-- RECORD TYPE IS CONSTRAINED BY DEFAULT - USED TO DECLARE AN +-- ARRAY OR RECORD COMPONENT, THAT THE NON-DISCRIMINANT EXPRESSIONS +-- OF THE CONSTRAINT ARE CHECKED FOR COMPATIBILITY: +-- 1) ONLY IN AN OBJECT DECLARATION, AND +-- 2) ONLY IF THE DESCRIMINANT-DEPENDENT COMPONENT IS PRESENT +-- IN THE SUBTYPE. + +-- HISTORY: +-- VCL 10/23/88 CREATED ORIGINAL TEST BY SPLITTING FROM C37213J. +-- VCL 03/30/88 MODIFIED THE TEST DISCRIPTION TO MORE ACCURATELY +-- DESCRIBE THE OBJECTIVE; CHANGED THE FORMAL +-- PARAMETERS TO THE GENERIC UNITS AND THE +-- CORRESPONDING ACTUAL PARAMETERS; REORGANIZED THE +-- TEST SO THAT ALL OPERATIONS ON A SPECIFIC TYPE +-- ARE TOGETHER; REWROTE ONE OF THE GENERIC +-- PACKAGES AS A GENERIC PROCEDURE TO BROADEN +-- COVERAGE OF TEST. + +WITH REPORT; USE REPORT; +PROCEDURE C37213K IS +BEGIN + TEST ("C37213K", "THE NON-DISCRIMINANT VALUES OF A DISCRIMINANT " & + "OR AN INDEX CONSTRAINT THAT DEPEND ON A " & + "DISCRIMINANT ARE PROPERLY CHECKED WHEN THE " & + "RECORD TYPE IS CONSTRAINED BY DEFAULT AND " & + "USED AS THE ACTUAL PARAMETER TO A GENERIC " & + "FORMAL TYPE USED TO DECLARE AN ARRAY OR A " & + "RECORD COMPONENT"); + + DECLARE + SUBTYPE SM IS INTEGER RANGE 1..10; + TYPE REC (D1, D2 : SM) IS + RECORD NULL; END RECORD; + TYPE MY_ARR IS ARRAY (SM RANGE <>) OF INTEGER; + + SEQUENCE_NUMBER : INTEGER; + + GENERIC + TYPE CONS IS PRIVATE; + OBJ_XCP : BOOLEAN; + TAG : STRING; + PACKAGE ARRAY_COMP_CHK IS END ARRAY_COMP_CHK; + + PACKAGE BODY ARRAY_COMP_CHK IS + BEGIN + DECLARE + TYPE ARR IS ARRAY (1..5) OF CONS; + BEGIN + DECLARE + X : ARR; + + FUNCTION VALUE RETURN ARR IS + BEGIN + IF EQUAL (3,3) THEN + RETURN X; + ELSE + RETURN X; + END IF; + END VALUE; + BEGIN + IF OBJ_XCP THEN + FAILED ("NO CHECK DURING DECLARATION " & + "OF OBJECT OF TYPE ARR - " & TAG); + ELSIF X /= VALUE THEN + FAILED ("INCORRECT VALUE FOR OBJECT OF " & + "TYPE ARR - " & TAG); + END IF; + END; + EXCEPTION + WHEN CONSTRAINT_ERROR => + IF NOT OBJ_XCP THEN + FAILED ("IMPROPER CONSTRAINT CHECKED " & + "DURING DECLARATION OF OBJECT " & + "OF TYPE ARR - " & TAG); + END IF; + END; + EXCEPTION + WHEN CONSTRAINT_ERROR => + FAILED ("CONSTRAINT IMPROPERLY CHECKED " & + "DURING DECLARATION OF ARR - " & TAG); + END ARRAY_COMP_CHK; + + GENERIC + TYPE CONS IS PRIVATE; + PROCEDURE REC_COMP_CHK (OBJ_XCP : BOOLEAN; + TAG : STRING); + + PROCEDURE REC_COMP_CHK (OBJ_XCP : BOOLEAN; + TAG : STRING) IS + BEGIN + DECLARE + TYPE NREC IS + RECORD + C1 : CONS; + END RECORD; + BEGIN + DECLARE + X : NREC; + + FUNCTION VALUE RETURN NREC IS + BEGIN + IF EQUAL (5, 5) THEN + RETURN X; + ELSE + RETURN X; + END IF; + END VALUE; + BEGIN + IF OBJ_XCP THEN + FAILED ("NO CHECK DURING DECLARATION " & + "OF OBJECT OF TYPE NREC - " & + TAG); + ELSIF X /= VALUE THEN + FAILED ("INCORRECT VALUE FOR OBJECT " & + "OF TYPE NREC - " & TAG); + END IF; + END; + EXCEPTION + WHEN CONSTRAINT_ERROR => + IF NOT OBJ_XCP THEN + FAILED ("IMPROPER CONSTRAINT CHECKED " & + "DURING DECLARATION OF OBJECT " & + "OF TYPE NREC - " & TAG); + END IF; + END; + EXCEPTION + WHEN CONSTRAINT_ERROR => + FAILED ("CONSTRAINT IMPROPERLY CHECKED " & + "DURING DECLARATION OF NREC - " & TAG); + END; + BEGIN + SEQUENCE_NUMBER := 1; + DECLARE + TYPE REC_DEF (D3 : INTEGER := 1) IS + RECORD + C1 : REC (D3, 0); + END RECORD; + + PACKAGE PACK1 IS NEW ARRAY_COMP_CHK (REC_DEF, + OBJ_XCP => TRUE, + TAG => "PACK1"); + + PROCEDURE PROC1 IS NEW REC_COMP_CHK (REC_DEF); + BEGIN + PROC1 (OBJ_XCP => TRUE, TAG => "PROC1"); + END; + + SEQUENCE_NUMBER := 2; + DECLARE + TYPE ARR_DEF (D3 : INTEGER := IDENT_INT(1)) IS + RECORD + C1 : MY_ARR (0..D3); + END RECORD; + + PACKAGE PACK2 IS NEW ARRAY_COMP_CHK (ARR_DEF, + OBJ_XCP => TRUE, + TAG => "PACK2"); + + PROCEDURE PROC2 IS NEW REC_COMP_CHK (ARR_DEF); + BEGIN + PROC2 (OBJ_XCP => TRUE, TAG => "PROC2"); + END; + + SEQUENCE_NUMBER := 3; + DECLARE + TYPE VAR_REC_DEF1 (D3 : INTEGER := 1) IS + RECORD + CASE D3 IS + WHEN -5..10 => + C1 : REC (D3, IDENT_INT(11)); + WHEN OTHERS => + C2 : INTEGER := IDENT_INT(5); + END CASE; + END RECORD; + + PACKAGE PACK3 IS NEW ARRAY_COMP_CHK (VAR_REC_DEF1, + OBJ_XCP => TRUE, + TAG => "PACK3"); + + PROCEDURE PROC3 IS NEW REC_COMP_CHK (VAR_REC_DEF1); + BEGIN + PROC3 (OBJ_XCP => TRUE, TAG => "PROC3"); + END; + + SEQUENCE_NUMBER := 4; + DECLARE + TYPE VAR_REC_DEF6 (D3 : INTEGER := IDENT_INT(-6)) IS + RECORD + CASE D3 IS + WHEN -5..10 => + C1 : REC (D3, IDENT_INT(11)); + WHEN OTHERS => + C2 : INTEGER := IDENT_INT(5); + END CASE; + END RECORD; + + PACKAGE PACK4 IS NEW ARRAY_COMP_CHK (VAR_REC_DEF6, + OBJ_XCP => FALSE, + TAG => "PACK4"); + + PROCEDURE PROC4 IS NEW REC_COMP_CHK (VAR_REC_DEF6); + BEGIN + PROC4 (OBJ_XCP => FALSE, TAG => "PROC4"); + END; + + SEQUENCE_NUMBER := 5; + DECLARE + TYPE VAR_REC_DEF11 (D3 : INTEGER := 11) IS + RECORD + CASE D3 IS + WHEN -5..10 => + C1 : REC (D3, IDENT_INT(11)); + WHEN OTHERS => + C2 : INTEGER := IDENT_INT(5); + END CASE; + END RECORD; + + PACKAGE PACK5 IS NEW ARRAY_COMP_CHK (VAR_REC_DEF11, + OBJ_XCP => FALSE, + TAG => "PACK5"); + + PROCEDURE PROC5 IS NEW REC_COMP_CHK (VAR_REC_DEF11); + BEGIN + PROC5 (OBJ_XCP => FALSE, TAG => "PROC5"); + END; + + SEQUENCE_NUMBER := 6; + DECLARE + TYPE VAR_ARR_DEF1 (D3 : INTEGER := IDENT_INT(1)) IS + RECORD + CASE D3 IS + WHEN -5..10 => + C1 : MY_ARR(D3..IDENT_INT(11)); + WHEN OTHERS => + C2 : INTEGER := IDENT_INT(5); + END CASE; + END RECORD; + + PACKAGE PACK6 IS NEW ARRAY_COMP_CHK (VAR_ARR_DEF1, + OBJ_XCP => TRUE, + TAG => "PACK6"); + + PROCEDURE PROC6 IS NEW REC_COMP_CHK (VAR_ARR_DEF1); + BEGIN + PROC6 (OBJ_XCP => TRUE, TAG => "PROC6"); + END; + + SEQUENCE_NUMBER := 7; + DECLARE + TYPE VAR_ARR_DEF6 (D3 : INTEGER := -6) IS + RECORD + CASE D3 IS + WHEN -5..10 => + C1 : MY_ARR(D3..IDENT_INT(11)); + WHEN OTHERS => + C2 : INTEGER := IDENT_INT(5); + END CASE; + END RECORD; + + PACKAGE PACK7 IS NEW ARRAY_COMP_CHK (VAR_ARR_DEF6, + OBJ_XCP => FALSE, + TAG => "PACK7"); + + PROCEDURE PROC7 IS NEW REC_COMP_CHK (VAR_ARR_DEF6); + BEGIN + PROC7 (OBJ_XCP => FALSE, TAG => "PROC7"); + END; + + SEQUENCE_NUMBER := 8; + DECLARE + TYPE VAR_ARR_DEF11 (D3 : INTEGER := IDENT_INT(11)) IS + RECORD + CASE D3 IS + WHEN -5..10 => + C1 : MY_ARR(D3..IDENT_INT(11)); + WHEN OTHERS => + C2 : INTEGER := IDENT_INT(5); + END CASE; + END RECORD; + + PACKAGE PACK8 IS NEW ARRAY_COMP_CHK (VAR_ARR_DEF11, + OBJ_XCP => FALSE, + TAG => "PACK8"); + + PROCEDURE PROC8 IS NEW REC_COMP_CHK (VAR_ARR_DEF11); + BEGIN + PROC8 (OBJ_XCP => FALSE, TAG => "PROC8"); + END; + EXCEPTION + WHEN OTHERS => + FAILED ("UNEXPECTED EXCEPTION RAISED DURING " & + "DECLARATION / INSTANTIATION ELABORATION - " & + INTEGER'IMAGE (SEQUENCE_NUMBER)); + END; + + RESULT; +END C37213K; diff --git a/gcc-4.9/gcc/testsuite/ada/acats/tests/c3/c37213l.ada b/gcc-4.9/gcc/testsuite/ada/acats/tests/c3/c37213l.ada new file mode 100644 index 000000000..07bd124f4 --- /dev/null +++ b/gcc-4.9/gcc/testsuite/ada/acats/tests/c3/c37213l.ada @@ -0,0 +1,329 @@ +-- C37213L.ADA + +-- Grant of Unlimited Rights +-- +-- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687, +-- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained +-- unlimited rights in the software and documentation contained herein. +-- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making +-- this public release, the Government intends to confer upon all +-- recipients unlimited rights equal to those held by the Government. +-- These rights include rights to use, duplicate, release or disclose the +-- released technical data and computer software in whole or in part, in +-- any manner and for any purpose whatsoever, and to have or permit others +-- to do so. +-- +-- DISCLAIMER +-- +-- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR +-- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED +-- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE +-- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE +-- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A +-- PARTICULAR PURPOSE OF SAID MATERIAL. +--* +-- OBJECTIVE: +-- CHECK, FOR A GENERIC FORMAL TYPE - WHERE A DISCRIMINANT OR AN +-- INDEX CONSTRAINT DEPENDS ON A RECORD DISCRIMINANT AND THE +-- RECORD TYPE IS CONSTRAINED BY DEFAULT - USED TO DECLARE A +-- DERIVED OR AN ACCESS TYPE, THAT THE NON-DISCRIMINANT EXPRESSIONS +-- OF THE CONSTRAINT ARE CHECKED FOR COMPATIBILITY: +-- 1) ONLY IN AN OBJECT DECLARATION OR ALLOCATOR, AND +-- 2) ONLY IF THE DISCRIMINANT-DEPENDENT COMPONENT IS PRESENT +-- IN THE SUBTYPE. + +-- HISTORY: +-- VCL 10/23/88 CREATED ORIGINAL TEST BY SPLITTING FROM C37213J. +-- VCL 03/30/88 MODIFIED THE TEST DISCRIPTION TO MORE ACCURATELY +-- DESCRIBE THE OBJECTIVE; CHANGED THE FORMAL +-- PARAMETERS TO THE GENERIC UNITS AND THE +-- CORRESPONDING ACTUAL PARAMETERS; REORGANIZED THE +-- TEST SO THAT ALL OPERATIONS ON A SPECIFIC TYPE +-- ARE TOGETHER; REWROTE ONE OF THE GENERIC +-- PACKAGES AS A GENERIC PROCEDURE TO BROADEN +-- COVERAGE OF TEST. + +WITH REPORT; USE REPORT; +PROCEDURE C37213L IS +BEGIN + TEST ("C37213L", "THE NON-DISCRIMINANT VALUES OF A DISCRIMINANT " & + "OR AN INDEX CONSTRAINT THAT DEPEND ON A " & + "DISCRIMINANT ARE PROPERLY CHECKED WHEN THE " & + "RECORD TYPE IS CONSTRAINED BY DEFAULT AND " & + "USED AS THE ACTUAL PARAMETER TO A GENERIC " & + "FORMAL TYPE USED TO DECLARE A DERIVED OR AN " & + "ACCESS TYPE"); + + DECLARE + SUBTYPE SM IS INTEGER RANGE 1..10; + TYPE REC (D1, D2 : SM) IS + RECORD NULL; END RECORD; + TYPE MY_ARR IS ARRAY (SM RANGE <>) OF INTEGER; + + SEQUENCE_NUMBER : INTEGER; + + GENERIC + TYPE CONS IS PRIVATE; + OBJ_XCP : BOOLEAN; + TAG : STRING; + PACKAGE DER_CHK IS END DER_CHK; + + PACKAGE BODY DER_CHK IS + BEGIN + DECLARE + TYPE DREC IS NEW CONS; + BEGIN + DECLARE + X : DREC; + + FUNCTION VALUE RETURN DREC IS + BEGIN + IF EQUAL (3,3) THEN + RETURN X; + ELSE + RETURN X; + END IF; + END VALUE; + BEGIN + IF OBJ_XCP THEN + FAILED ("NO CHECK DURING DECLARATION " & + "OF OBJECT OF TYPE DREC - " & + TAG); + ELSIF X /= VALUE THEN + FAILED ("INCORRECT VALUE FOR OBJECT OF " & + "TYPE DREC - " & TAG); + END IF; + END; + EXCEPTION + WHEN CONSTRAINT_ERROR => + IF NOT OBJ_XCP THEN + FAILED ("IMPROPER CONSTRAINT CHECKED " & + "DURING DECLARATION OF OBJECT " & + "OF TYPE DREC - " & TAG); + END IF; + END; + EXCEPTION + WHEN CONSTRAINT_ERROR => + FAILED ("CONSTRAINT IMPROPERLY CHECKED " & + "DURING DECLARATION OF DREC - " & TAG); + END; + + GENERIC + TYPE CONS IS PRIVATE; + PROCEDURE ACC_CHK (OBJ_XCP : BOOLEAN; + TAG : STRING); + + PROCEDURE ACC_CHK (OBJ_XCP : BOOLEAN; + TAG : STRING) IS + BEGIN + DECLARE + TYPE ACC_CONS IS ACCESS CONS; + BEGIN + DECLARE + X : ACC_CONS; + + FUNCTION VALUE RETURN CONS IS + BEGIN + IF EQUAL (5, 5) THEN + RETURN X.ALL; + ELSE + RETURN X.ALL; + END IF; + END VALUE; + BEGIN + X := NEW CONS; + + IF OBJ_XCP THEN + FAILED ("NO CHECK DURING ALLOCATION " & + "OF OBJECT OF TYPE CONS - " & + TAG); + ELSIF X.ALL /= VALUE THEN + FAILED ("INCORRECT VALUE FOR OBJECT " & + "OF TYPE CONS - " & TAG); + END IF; + EXCEPTION + WHEN CONSTRAINT_ERROR => + IF NOT OBJ_XCP THEN + FAILED ("IMPROPER CONSTRAINT " & + "CHECKED DURING " & + "ALLOCATION OF OBJECT " & + "OF TYPE CONS - " & TAG); + END IF; + END; + EXCEPTION + WHEN CONSTRAINT_ERROR => + FAILED ("CONSTRAINT IMPROPERLY CHECKED " & + "DURING DECLARATION OF X - " & TAG); + END; + EXCEPTION + WHEN CONSTRAINT_ERROR => + FAILED ("CONSTRAINT IMPROPERLY CHECKED " & + "DURING DECLARATION OF ACC_CONS - " & TAG); + END ACC_CHK; + BEGIN + SEQUENCE_NUMBER := 1; + DECLARE + TYPE REC_DEF (D3 : INTEGER := 1) IS + RECORD + C1 : REC (D3, 0); + END RECORD; + + PACKAGE PACK1 IS NEW DER_CHK (REC_DEF, + OBJ_XCP => TRUE, + TAG => "PACK1"); + + PROCEDURE PROC1 IS NEW ACC_CHK (REC_DEF); + BEGIN + PROC1 (OBJ_XCP => TRUE, TAG => "PROC1"); + END; + + SEQUENCE_NUMBER := 2; + DECLARE + TYPE ARR_DEF (D3 : INTEGER := IDENT_INT(1)) IS + RECORD + C1 : MY_ARR (0..D3); + END RECORD; + + PACKAGE PACK2 IS NEW DER_CHK (ARR_DEF, + OBJ_XCP => TRUE, + TAG => "PACK2"); + + PROCEDURE PROC2 IS NEW ACC_CHK (ARR_DEF); + BEGIN + PROC2 (OBJ_XCP => TRUE, TAG => "PROC2"); + END; + + SEQUENCE_NUMBER := 3; + DECLARE + TYPE VAR_REC_DEF1 (D3 : INTEGER := 1) IS + RECORD + CASE D3 IS + WHEN -5..10 => + C1 : REC (D3, IDENT_INT(11)); + WHEN OTHERS => + C2 : INTEGER := IDENT_INT(5); + END CASE; + END RECORD; + + PACKAGE PACK3 IS NEW DER_CHK (VAR_REC_DEF1, + OBJ_XCP => TRUE, + TAG => "PACK3"); + + PROCEDURE PROC3 IS NEW ACC_CHK (VAR_REC_DEF1); + BEGIN + PROC3 (OBJ_XCP => TRUE, TAG => "PROC3"); + END; + + SEQUENCE_NUMBER := 4; + DECLARE + TYPE VAR_REC_DEF6 (D3 : INTEGER := IDENT_INT(-6)) IS + RECORD + CASE D3 IS + WHEN -5..10 => + C1 : REC (D3, IDENT_INT(11)); + WHEN OTHERS => + C2 : INTEGER := IDENT_INT(5); + END CASE; + END RECORD; + + PACKAGE PACK4 IS NEW DER_CHK (VAR_REC_DEF6, + OBJ_XCP => FALSE, + TAG => "PACK4"); + + PROCEDURE PROC4 IS NEW ACC_CHK (VAR_REC_DEF6); + BEGIN + PROC4 (OBJ_XCP => FALSE, TAG => "PROC4"); + END; + + SEQUENCE_NUMBER := 5; + DECLARE + TYPE VAR_REC_DEF11 (D3 : INTEGER := 11) IS + RECORD + CASE D3 IS + WHEN -5..10 => + C1 : REC (D3, IDENT_INT(11)); + WHEN OTHERS => + C2 : INTEGER := IDENT_INT(5); + END CASE; + END RECORD; + + PACKAGE PACK5 IS NEW DER_CHK (VAR_REC_DEF11, + OBJ_XCP => FALSE, + TAG => "PACK5"); + + PROCEDURE PROC5 IS NEW ACC_CHK (VAR_REC_DEF11); + BEGIN + PROC5 (OBJ_XCP => FALSE, TAG => "PROC5"); + END; + + SEQUENCE_NUMBER := 6; + DECLARE + TYPE VAR_ARR_DEF1 (D3 : INTEGER := IDENT_INT(1)) IS + RECORD + CASE D3 IS + WHEN -5..10 => + C1 : MY_ARR(D3..IDENT_INT(11)); + WHEN OTHERS => + C2 : INTEGER := IDENT_INT(5); + END CASE; + END RECORD; + + PACKAGE PACK6 IS NEW DER_CHK (VAR_ARR_DEF1, + OBJ_XCP => TRUE, + TAG => "PACK6"); + + PROCEDURE PROC6 IS NEW ACC_CHK (VAR_ARR_DEF1); + BEGIN + PROC6 (OBJ_XCP => TRUE, TAG => "PROC6"); + END; + + SEQUENCE_NUMBER := 7; + DECLARE + TYPE VAR_ARR_DEF6 (D3 : INTEGER := -6) IS + RECORD + CASE D3 IS + WHEN -5..10 => + C1 : MY_ARR(D3..IDENT_INT(11)); + WHEN OTHERS => + C2 : INTEGER := IDENT_INT(5); + END CASE; + END RECORD; + + PACKAGE PACK7 IS NEW DER_CHK (VAR_ARR_DEF6, + OBJ_XCP => FALSE, + TAG => "PACK7"); + + PROCEDURE PROC7 IS NEW ACC_CHK (VAR_ARR_DEF6); + BEGIN + PROC7 (OBJ_XCP => FALSE, TAG => "PROC7"); + END; + + SEQUENCE_NUMBER := 8; + DECLARE + TYPE VAR_ARR_DEF11 (D3 : INTEGER := IDENT_INT(11)) IS + RECORD + CASE D3 IS + WHEN -5..10 => + C1 : MY_ARR(D3..IDENT_INT(11)); + WHEN OTHERS => + C2 : INTEGER := IDENT_INT(5); + END CASE; + END RECORD; + + PACKAGE PACK8 IS NEW DER_CHK (VAR_ARR_DEF11, + OBJ_XCP => FALSE, + TAG => "PACK8"); + + PROCEDURE PROC8 IS NEW ACC_CHK (VAR_ARR_DEF11); + BEGIN + PROC8 (OBJ_XCP => FALSE, TAG => "PROC8"); + END; + EXCEPTION + WHEN OTHERS => + FAILED ("UNEXPECTED EXCEPTION RAISED DURING " & + "DECLARATION / INSTANTIATION ELABORATION - " & + INTEGER'IMAGE (SEQUENCE_NUMBER)); + END; + + RESULT; +END C37213L; diff --git a/gcc-4.9/gcc/testsuite/ada/acats/tests/c3/c37215b.ada b/gcc-4.9/gcc/testsuite/ada/acats/tests/c3/c37215b.ada new file mode 100644 index 000000000..408804e17 --- /dev/null +++ b/gcc-4.9/gcc/testsuite/ada/acats/tests/c3/c37215b.ada @@ -0,0 +1,203 @@ +-- C37215B.ADA + +-- Grant of Unlimited Rights +-- +-- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687, +-- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained +-- unlimited rights in the software and documentation contained herein. +-- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making +-- this public release, the Government intends to confer upon all +-- recipients unlimited rights equal to those held by the Government. +-- These rights include rights to use, duplicate, release or disclose the +-- released technical data and computer software in whole or in part, in +-- any manner and for any purpose whatsoever, and to have or permit others +-- to do so. +-- +-- DISCLAIMER +-- +-- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR +-- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED +-- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF 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 DISCRIMINANT CONSTRAINT +-- DEPENDS ON A DISCRIMINANT, THE DISCRIMINANT VALUE IS CHECKED FOR +-- COMPATIBILITY WHEN THE RECORD TYPE IS: +-- +-- CASE B: USED WITHOUT A CONSTRAINT ONLY IN AN ALLOCATOR OR OBJECT +-- DECLARATION. + +-- JBG 10/17/86 + +WITH REPORT; USE REPORT; +PROCEDURE C37215B IS + + SUBTYPE SM IS INTEGER RANGE 1..10; + + TYPE REC (D1, D2 : SM) IS + RECORD NULL; END RECORD; + +BEGIN + TEST ("C37215B", "CHECK COMPATIBILITY OF DISCRIMINANT EXPRESSIONS"& + " WHEN CONSTRAINT DEPENDS ON DISCRIMINANT, " & + "AND DISCRIMINANTS HAVE DEFAULTS"); + +-- CASE B + + DECLARE + TYPE CONS (D3 : INTEGER := IDENT_INT(11)) IS + RECORD + C1 : REC(D3, 1); + END RECORD; + BEGIN + BEGIN + DECLARE + X : CONS; + BEGIN + FAILED ("DISCRIMINANT CHECK NOT PERFORMED - 1"); + IF X /= (1, (1, 1)) THEN + COMMENT ("SHOULDN'T GET HERE"); + END IF; + END; + EXCEPTION + WHEN CONSTRAINT_ERROR => + NULL; + WHEN OTHERS => + FAILED ("UNEXPECTED EXCEPTION - 1"); + END; + + BEGIN + DECLARE + TYPE ACC_CONS IS ACCESS CONS; + X : ACC_CONS; + BEGIN + X := NEW CONS; + FAILED ("DISCRIMINANT CHECK NOT PERFORMED - 2"); + BEGIN + IF X.ALL /= (1, (1, 1)) THEN + COMMENT ("IRRELEVANT"); + END IF; + END; + EXCEPTION + WHEN CONSTRAINT_ERROR => + NULL; + WHEN OTHERS => + FAILED ("UNEXPECTED EXCEPTION RAISED - 2"); + END; + EXCEPTION + WHEN OTHERS => + FAILED ("CONSTRAINT CHECKED TOO SOON - 2"); + END; + + BEGIN + DECLARE + SUBTYPE SCONS IS CONS; + BEGIN + DECLARE + X : SCONS; + BEGIN + FAILED ("DISCRIMINANT CHECK NOT " & + "PERFORMED - 3"); + IF X /= (1, (1, 1)) THEN + COMMENT ("IRRELEVANT"); + END IF; + END; + EXCEPTION + WHEN CONSTRAINT_ERROR => + NULL; + WHEN OTHERS => + FAILED ("UNEXPECTED EXCEPTION RAISED - 3"); + END; + EXCEPTION + WHEN OTHERS => + FAILED ("CONSTRAINT CHECKED TOO SOON - 3"); + END; + + BEGIN + DECLARE + TYPE ARR IS ARRAY (1..5) OF CONS; + BEGIN + DECLARE + X : ARR; + BEGIN + FAILED ("DISCRIMINANT CHECK NOT " & + "PERFORMED - 4"); + IF X /= (1..5 => (1, (1, 1))) THEN + COMMENT ("IRRELEVANT"); + END IF; + END; + EXCEPTION + WHEN CONSTRAINT_ERROR => + NULL; + WHEN OTHERS => + FAILED ("UNEXPECTED EXCEPTION RAISED - 4"); + END; + EXCEPTION + WHEN OTHERS => + FAILED ("CONSTRAINT CHECKED TOO SOON - 4"); + END; + + BEGIN + DECLARE + TYPE NREC IS + RECORD + C1 : CONS; + END RECORD; + BEGIN + DECLARE + X : NREC; + BEGIN + FAILED ("DISCRIMINANT CHECK NOT " & + "PERFORMED - 5"); + IF X /= (C1 => (1, (1, 1))) THEN + COMMENT ("IRRELEVANT"); + END IF; + END; + EXCEPTION + WHEN CONSTRAINT_ERROR => + NULL; + WHEN OTHERS => + FAILED ("UNEXPECTED EXCEPTION RAISED - 5"); + END; + EXCEPTION + WHEN OTHERS => + FAILED ("CONSTRAINT CHECKED TOO SOON - 5"); + END; + + BEGIN + DECLARE + TYPE DREC IS NEW CONS; + BEGIN + DECLARE + X : DREC; + BEGIN + FAILED ("DISCRIMINANT CHECK NOT " & + "PERFORMED - 6"); + IF X /= (1, (1, 1)) THEN + COMMENT ("IRRELEVANT"); + END IF; + END; + EXCEPTION + WHEN CONSTRAINT_ERROR => + NULL; + WHEN OTHERS => + FAILED ("UNEXPECTED EXCEPTION RAISED - 6"); + END; + EXCEPTION + WHEN OTHERS => + FAILED ("CONSTRAINT CHECKED TOO SOON - 6"); + END; + + END; + + RESULT; + +EXCEPTION + WHEN OTHERS => + FAILED ("CONSTRAINT CHECK DONE TOO EARLY"); + RESULT; + +END C37215B; diff --git a/gcc-4.9/gcc/testsuite/ada/acats/tests/c3/c37215d.ada b/gcc-4.9/gcc/testsuite/ada/acats/tests/c3/c37215d.ada new file mode 100644 index 000000000..3eefc5378 --- /dev/null +++ b/gcc-4.9/gcc/testsuite/ada/acats/tests/c3/c37215d.ada @@ -0,0 +1,202 @@ +-- C37215D.ADA + +-- Grant of Unlimited Rights +-- +-- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687, +-- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained +-- unlimited rights in the software and documentation contained herein. +-- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making +-- this public release, the Government intends to confer upon all +-- recipients unlimited rights equal to those held by the Government. +-- These rights include rights to use, duplicate, release or disclose the +-- released technical data and computer software in whole or in part, in +-- any manner and for any purpose whatsoever, and to have or permit others +-- to do so. +-- +-- DISCLAIMER +-- +-- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR +-- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED +-- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF 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 +-- AN INDEX CONSTRAINT +-- DEPENDS ON A DISCRIMINANT, THE DISCRIMINANT VALUE IS CHECKED FOR +-- COMPATIBILITY WHEN THE RECORD TYPE IS: +-- +-- CASE B: USED WITHOUT A CONSTRAINT ONLY IN AN ALLOCATOR OR OBJECT +-- DECLARATION. + +-- JBG 10/17/86 + +WITH REPORT; USE REPORT; +PROCEDURE C37215D IS + + SUBTYPE SM IS INTEGER RANGE 1..10; + + TYPE MY_ARR IS ARRAY (SM RANGE <>) OF INTEGER; + +BEGIN + TEST ("C37215D", "CHECK COMPATIBILITY OF INDEX BOUNDS " & + "WHEN CONSTRAINT DEPENDS ON DISCRIMINANT, " & + "AND DISCRIMINANTS HAVE DEFAULTS"); + +-- CASE B + + DECLARE + TYPE CONS (D3 : INTEGER := IDENT_INT(11)) IS + RECORD + C1 : MY_ARR(2..D3); + END RECORD; + BEGIN + BEGIN + DECLARE + X : CONS; + BEGIN + FAILED ("INDEX CHECK NOT PERFORMED - 1"); + IF X /= (1, (1, 1)) THEN + COMMENT ("SHOULDN'T GET HERE"); + END IF; + END; + EXCEPTION + WHEN CONSTRAINT_ERROR => + NULL; + WHEN OTHERS => + FAILED ("UNEXPECTED EXCEPTION - 1"); + END; + + BEGIN + DECLARE + TYPE ACC_CONS IS ACCESS CONS; + X : ACC_CONS; + BEGIN + X := NEW CONS; + FAILED ("INDEX CHECK NOT PERFORMED - 2"); + BEGIN + IF X.ALL /= (1, (1 => 1)) THEN + COMMENT ("IRRELEVANT"); + END IF; + END; + EXCEPTION + WHEN CONSTRAINT_ERROR => + NULL; + WHEN OTHERS => + FAILED ("UNEXPECTED EXCEPTION RAISED - 2"); + END; + EXCEPTION + WHEN OTHERS => + FAILED ("CONSTRAINT CHECKED TOO SOON - 2"); + END; + + BEGIN + DECLARE + SUBTYPE SCONS IS CONS; + BEGIN + DECLARE + X : SCONS; + BEGIN + FAILED ("INDEX CHECK NOT " & + "PERFORMED - 3"); + IF X /= (1, (1 => 1)) THEN + COMMENT ("IRRELEVANT"); + END IF; + END; + EXCEPTION + WHEN CONSTRAINT_ERROR => + NULL; + WHEN OTHERS => + FAILED ("UNEXPECTED EXCEPTION RAISED - 3"); + END; + EXCEPTION + WHEN OTHERS => + FAILED ("CONSTRAINT CHECKED TOO SOON - 3"); + END; + + BEGIN + DECLARE + TYPE ARR IS ARRAY (1..5) OF CONS; + BEGIN + DECLARE + X : ARR; + BEGIN + FAILED ("INDEX CHECK NOT " & + "PERFORMED - 4"); + IF X /= (1..5 => (1, (1 => 1))) THEN + COMMENT ("IRRELEVANT"); + END IF; + END; + EXCEPTION + WHEN CONSTRAINT_ERROR => + NULL; + WHEN OTHERS => + FAILED ("UNEXPECTED EXCEPTION RAISED - 4"); + END; + EXCEPTION + WHEN OTHERS => + FAILED ("CONSTRAINT CHECKED TOO SOON - 4"); + END; + + BEGIN + DECLARE + TYPE NREC IS + RECORD + C1 : CONS; + END RECORD; + BEGIN + DECLARE + X : NREC; + BEGIN + FAILED ("INDEX CHECK NOT " & + "PERFORMED - 5"); + IF X /= (C1 => (1, (1 => 1))) THEN + COMMENT ("IRRELEVANT"); + END IF; + END; + EXCEPTION + WHEN CONSTRAINT_ERROR => + NULL; + WHEN OTHERS => + FAILED ("UNEXPECTED EXCEPTION RAISED - 5"); + END; + EXCEPTION + WHEN OTHERS => + FAILED ("CONSTRAINT CHECKED TOO SOON - 5"); + END; + + BEGIN + DECLARE + TYPE DREC IS NEW CONS; + BEGIN + DECLARE + X : DREC; + BEGIN + FAILED ("INDEX CHECK NOT " & + "PERFORMED - 6"); + IF X /= (1, (1 => 1)) THEN + COMMENT ("IRRELEVANT"); + END IF; + END; + EXCEPTION + WHEN CONSTRAINT_ERROR => + NULL; + WHEN OTHERS => + FAILED ("UNEXPECTED EXCEPTION RAISED - 6"); + END; + EXCEPTION + WHEN OTHERS => + FAILED ("CONSTRAINT CHECKED TOO SOON - 6"); + END; + + END; + + RESULT; + +EXCEPTION + WHEN OTHERS => + FAILED ("CONSTRAINT CHECK DONE TOO EARLY"); + RESULT; + +END C37215D; diff --git a/gcc-4.9/gcc/testsuite/ada/acats/tests/c3/c37215f.ada b/gcc-4.9/gcc/testsuite/ada/acats/tests/c3/c37215f.ada new file mode 100644 index 000000000..1f34c4eae --- /dev/null +++ b/gcc-4.9/gcc/testsuite/ada/acats/tests/c3/c37215f.ada @@ -0,0 +1,313 @@ +-- C37215F.ADA + +-- Grant of Unlimited Rights +-- +-- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687, +-- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained +-- unlimited rights in the software and documentation contained herein. +-- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making +-- this public release, the Government intends to confer upon all +-- recipients unlimited rights equal to those held by the Government. +-- These rights include rights to use, duplicate, release or disclose the +-- released technical data and computer software in whole or in part, in +-- any manner and for any purpose whatsoever, and to have or permit others +-- to do so. +-- +-- DISCLAIMER +-- +-- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR +-- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED +-- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF 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 DISCRIMINANT CONSTRAINT +-- DEPENDS ON A DISCRIMINANT, THE DISCRIMINANT VALUE IS CHECKED FOR +-- COMPATIBILITY WHEN THE RECORD TYPE IS: +-- +-- CASE D: USED WITHOUT A CONSTRAINT ONLY IN AN ALLOCATOR OR OBJECT +-- DECLARATION AND THE COMPONENT IS PRESENT IN THE DEFAULT SUBTYPE. + +-- JBG 10/17/86 +-- PWN 05/31/96 Corrected format of call to "TEST" + +WITH REPORT; USE REPORT; +PROCEDURE C37215F IS + + SUBTYPE SM IS INTEGER RANGE 1..10; + + TYPE REC (D1, D2 : SM) IS + RECORD NULL; END RECORD; + +BEGIN + TEST ("C37215F", "CHECK EVALUATION OF DISCRIMINANT EXPRESSIONS " & + "WHEN CONSTRAINT DEPENDS ON DISCRIMINANT, " & + "DISCRIMINANTS HAVE DEFAULTS, AND COMPONENT " & + "SUBTYPE DETERMINES WHETHER CONSTRAINT SHOULD " & + "BE CHECKED"); + +-- CASE D1: COMPONENT IS PRESENT + + DECLARE + TYPE CONS (D3 : INTEGER := IDENT_INT(0)) IS + RECORD + CASE D3 IS + WHEN -5..10 => + C1 : REC(D3, 1); + WHEN OTHERS => + C2 : INTEGER := IDENT_INT(0); + END CASE; + END RECORD; + BEGIN + BEGIN + DECLARE + X : CONS; + BEGIN + FAILED ("DISCRIMINANT CHECK NOT PERFORMED - 1"); + IF X /= (1, (1, 1)) THEN + COMMENT ("SHOULDN'T GET HERE"); + END IF; + END; + EXCEPTION + WHEN CONSTRAINT_ERROR => + NULL; + WHEN OTHERS => + FAILED ("UNEXPECTED EXCEPTION - 1"); + END; + + BEGIN + DECLARE + TYPE ACC_CONS IS ACCESS CONS; + X : ACC_CONS; + BEGIN + X := NEW CONS; + FAILED ("DISCRIMINANT CHECK NOT PERFORMED - 2"); + IF X.ALL /= (1, (1, 1)) THEN + COMMENT ("IRRELEVANT"); + END IF; + EXCEPTION + WHEN CONSTRAINT_ERROR => + NULL; + WHEN OTHERS => + FAILED ("UNEXPECTED EXCEPTION RAISED - 2A"); + END; + EXCEPTION + WHEN OTHERS => + FAILED ("UNEXPECTED EXCEPTION RAISED - 2B"); + END; + + BEGIN + DECLARE + SUBTYPE SCONS IS CONS; + BEGIN + DECLARE + X : SCONS; + BEGIN + FAILED ("DISCRIMINANT CHECK NOT " & + "PERFORMED - 3"); + IF X /= (1, (1, 1)) THEN + COMMENT ("IRRELEVANT"); + END IF; + END; + EXCEPTION + WHEN CONSTRAINT_ERROR => + NULL; + WHEN OTHERS => + FAILED ("UNEXPECTED EXCEPTION RAISED - 3"); + END; + EXCEPTION + WHEN OTHERS => + FAILED ("CONSTRAINT CHECKED TOO SOON - 3"); + END; + + BEGIN + DECLARE + TYPE ARR IS ARRAY (1..5) OF CONS; + BEGIN + DECLARE + X : ARR; + BEGIN + FAILED ("DISCRIMINANT CHECK NOT " & + "PERFORMED - 4"); + IF X /= (1..5 => (1, (1, 1))) THEN + COMMENT ("IRRELEVANT"); + END IF; + END; + EXCEPTION + WHEN CONSTRAINT_ERROR => + NULL; + WHEN OTHERS => + FAILED ("UNEXPECTED EXCEPTION RAISED - 4"); + END; + EXCEPTION + WHEN OTHERS => + FAILED ("CONSTRAINT CHECKED TOO SOON - 4"); + END; + + BEGIN + DECLARE + TYPE NREC IS + RECORD + C1 : CONS; + END RECORD; + BEGIN + DECLARE + X : NREC; + BEGIN + FAILED ("DISCRIMINANT CHECK NOT " & + "PERFORMED - 5"); + IF X /= (C1 => (1, (1, 1))) THEN + COMMENT ("IRRELEVANT"); + END IF; + END; + EXCEPTION + WHEN CONSTRAINT_ERROR => + NULL; + WHEN OTHERS => + FAILED ("UNEXPECTED EXCEPTION RAISED - 5"); + END; + EXCEPTION + WHEN OTHERS => + FAILED ("CONSTRAINT CHECKED TOO SOON - 5"); + END; + + BEGIN + DECLARE + TYPE DREC IS NEW CONS; + BEGIN + DECLARE + X : DREC; + BEGIN + FAILED ("DISCRIMINANT CHECK NOT " & + "PERFORMED - 6"); + IF X /= (1, (1, 1)) THEN + COMMENT ("IRRELEVANT"); + END IF; + END; + EXCEPTION + WHEN CONSTRAINT_ERROR => + NULL; + WHEN OTHERS => + FAILED ("UNEXPECTED EXCEPTION RAISED - 6"); + END; + EXCEPTION + WHEN OTHERS => + FAILED ("CONSTRAINT CHECKED TOO SOON - 6"); + END; + + END; + +-- CASE C2 : COMPONENT IS ABSENT + + DECLARE + TYPE CONS (D3 : INTEGER := IDENT_INT(11)) IS + RECORD + CASE D3 IS + WHEN -5..10 => + C1 : REC(D3, IDENT_INT(1)); + WHEN OTHERS => + C2 : INTEGER := IDENT_INT(5); + END CASE; + END RECORD; + BEGIN + BEGIN + DECLARE + X : CONS; + BEGIN + IF X /= (11, 5) THEN + FAILED ("WRONG VALUE FOR X - 11"); + END IF; + END; + EXCEPTION + WHEN OTHERS => + FAILED ("NONEXISTENT CONSTRAINT CHECKED - 11"); + END; + + BEGIN + DECLARE + SUBTYPE SCONS IS CONS; + BEGIN + DECLARE + X : SCONS; + BEGIN + IF X /= (11, 5) THEN + FAILED ("X VALUE WRONG - 12"); + END IF; + END; + END; + EXCEPTION + WHEN OTHERS => + FAILED ("NONEXISTENT CONSTRAINT CHECKED - 12"); + END; + + BEGIN + DECLARE + TYPE ARR IS ARRAY (1..5) OF CONS; + X : ARR; + BEGIN + IF X /= (1..5 => (11, 5)) THEN + FAILED ("X VALUE INCORRECT - 13"); + END IF; + END; + EXCEPTION + WHEN OTHERS => + FAILED ("NONEXISTENT CONSTRAINT CHECKED - 13"); + END; + + BEGIN + DECLARE + TYPE NREC IS + RECORD + C1 : CONS; + END RECORD; + X : NREC; + BEGIN + IF X /= (C1 => (11, 5)) THEN + FAILED ("X VALUE IS INCORRECT - 14"); + END IF; + END; + EXCEPTION + WHEN OTHERS => + FAILED ("NONEXISTENT CONSTRAINT CHECKED - 14"); + END; + + BEGIN + DECLARE + TYPE NREC IS NEW CONS; + X : NREC; + BEGIN + IF X /= (11, 5) THEN + FAILED ("X VALUE INCORRECT - 15"); + END IF; + END; + EXCEPTION + WHEN OTHERS => + FAILED ("NONEXISTENT CONSTRAINT CHECKED - 15"); + END; + + BEGIN + DECLARE + TYPE ACC_CONS IS ACCESS CONS; + X : ACC_CONS := NEW CONS; + BEGIN + IF X.ALL /= (11, 5) THEN + FAILED ("X VALUE INCORRECT - 17"); + END IF; + END; + EXCEPTION + WHEN OTHERS => + FAILED ("NONEXISTENT CONSTRAINT CHECKED - 17"); + END; + END; + + + RESULT; + +EXCEPTION + WHEN OTHERS => + FAILED ("CONSTRAINT CHECK DONE TOO EARLY"); + RESULT; + +END C37215F; diff --git a/gcc-4.9/gcc/testsuite/ada/acats/tests/c3/c37215h.ada b/gcc-4.9/gcc/testsuite/ada/acats/tests/c3/c37215h.ada new file mode 100644 index 000000000..c98180a3c --- /dev/null +++ b/gcc-4.9/gcc/testsuite/ada/acats/tests/c3/c37215h.ada @@ -0,0 +1,345 @@ +-- C37215H.ADA + +-- Grant of Unlimited Rights +-- +-- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687, +-- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained +-- unlimited rights in the software and documentation contained herein. +-- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making +-- this public release, the Government intends to confer upon all +-- recipients unlimited rights equal to those held by the Government. +-- These rights include rights to use, duplicate, release or disclose the +-- released technical data and computer software in whole or in part, in +-- any manner and for any purpose whatsoever, and to have or permit others +-- to do so. +-- +-- DISCLAIMER +-- +-- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR +-- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED +-- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF 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 AN INDEX CONSTRAINT DEPENDS ON A DISCRIMINANT, +-- THE DISCRIMINANT VALUE IS CHECKED FOR COMPATIBILITY WHEN THE +-- RECORD TYPE IS: +-- +-- CASE D: CONSTRAINED BY DEFAULT AND THE COMPONENT IS +-- PRESENT IN THE SUBTYPE. + +-- HISTORY: +-- JBG 10/17/86 CREATED ORIGINAL TEST. +-- RJW 10/13/87 CORRECTED VARIOUS CONSTRAINT ERRORS IN 'CASE D1'. +-- VCL 03/30/88 CORRECTED VARIOUS CONSTRAINT ERRORS WITH TYPE +-- DECLARATIONS THROUGHOUT THE TEST. ADDED SEQUENCE +-- NUMBERS. + +WITH REPORT; USE REPORT; +PROCEDURE C37215H IS + + SUBTYPE SM IS INTEGER RANGE 1..10; + TYPE MY_ARR IS ARRAY (SM RANGE <>) OF INTEGER; + + SEQUENCE_NUMBER : INTEGER; +BEGIN + TEST ("C37215H", "THE DISCRIMINANT VALUES OF AN INDEX " & + "CONSTRAINT ARE PROPERLY CHECK FOR " & + "COMPATIBILITY WHEN THE DISCRIMINANT IS " & + "DEFINED BY DEFAULT AND THE COMPONENT IS AND " & + "IS NOT PRESENT IN THE SUBTYPE"); + +-- CASE D1: COMPONENT IS PRESENT + + SEQUENCE_NUMBER := 1; + DECLARE + TYPE CONS (D3 : INTEGER := IDENT_INT(0)) IS + RECORD + CASE D3 IS + WHEN -5..10 => + C1 : MY_ARR(D3..1); + WHEN OTHERS => + C2 : INTEGER := IDENT_INT(0); + END CASE; + END RECORD; + BEGIN + BEGIN + DECLARE + X : CONS; + BEGIN + FAILED ("INDEX CHECK NOT PERFORMED - 1"); + IF X /= (1, (1, 1)) THEN + COMMENT ("SHOULDN'T GET HERE"); + END IF; + END; + EXCEPTION + WHEN CONSTRAINT_ERROR => + NULL; + WHEN OTHERS => + FAILED ("UNEXPECTED EXCEPTION RAISED - 1"); + END; + + BEGIN + DECLARE + SUBTYPE SCONS IS CONS; + BEGIN + DECLARE + X : SCONS; + BEGIN + FAILED ("INDEX CHECK NOT PERFORMED - 2"); + IF X /= (1, (1, 1)) THEN + COMMENT ("IRRELEVANT"); + END IF; + END; + EXCEPTION + WHEN CONSTRAINT_ERROR => + NULL; + WHEN OTHERS => + FAILED ("UNEXPECTED EXCEPTION RAISED - 2A"); + END; + EXCEPTION + WHEN OTHERS => + FAILED ("UNEXPECTED EXCEPTION RAISED - 2B"); + END; + + BEGIN + DECLARE + TYPE ARR IS ARRAY (1..5) OF CONS; + BEGIN + DECLARE + X : ARR; + BEGIN + FAILED ("INDEX CHECK NOT PERFORMED - 3"); + IF X /= (1..5 => (1, (1, 1))) THEN + COMMENT ("IRRELEVANT"); + END IF; + END; + EXCEPTION + WHEN CONSTRAINT_ERROR => + NULL; + WHEN OTHERS => + FAILED ("UNEXPECTED EXCEPTION RAISED - 3A"); + END; + EXCEPTION + WHEN OTHERS => + FAILED ("UNEXPECTED EXCEPTION RAISED - 3B"); + END; + + BEGIN + DECLARE + TYPE NREC IS + RECORD + C1 : CONS; + END RECORD; + BEGIN + DECLARE + X : NREC; + BEGIN + FAILED ("INDEX CHECK NOT PERFORMED - 4"); + IF X /= (C1 => (1, (1, 1))) THEN + COMMENT ("IRRELEVANT"); + END IF; + END; + EXCEPTION + WHEN CONSTRAINT_ERROR => + NULL; + WHEN OTHERS => + FAILED ("UNEXPECTED EXCEPTION RAISED - 4A"); + END; + EXCEPTION + WHEN OTHERS => + FAILED ("UNEXPECTED EXCEPTION RAISED - 4B"); + END; + + BEGIN + DECLARE + TYPE NREC IS NEW CONS; + BEGIN + DECLARE + X : NREC; + BEGIN + FAILED ("INDEX CHECK NOT PERFORMED - 5"); + IF X /= (1, (1, 1)) THEN + COMMENT ("IRRELEVANT"); + END IF; + END; + EXCEPTION + WHEN CONSTRAINT_ERROR => + NULL; + WHEN OTHERS => + FAILED ("UNEXPECTED EXCEPTION RAISED - 5A"); + END; + EXCEPTION + WHEN OTHERS => + FAILED ("UNEXPECTED EXCEPTION RAISED - 5B"); + END; + + BEGIN + DECLARE + TYPE ACC_CONS IS ACCESS CONS; + BEGIN + DECLARE + X : ACC_CONS; + BEGIN + X := NEW CONS; + FAILED ("INDEX CHECK NOT PERFORMED - 6"); + IF X.ALL /= (1, (1, 1)) THEN + COMMENT ("WRONG VALUE FOR X - 6"); + END IF; + EXCEPTION + WHEN CONSTRAINT_ERROR => + NULL; + WHEN OTHERS => + FAILED ("UNEXPECTED EXCEPTION RAISED " & + "- 6A"); + END; + EXCEPTION + WHEN OTHERS => + FAILED ("UNEXPECTED EXCEPTION RAISED - 6B"); + END; + EXCEPTION + WHEN OTHERS => + FAILED ("UNEXPECTED EXCEPTION RAISED - 6C"); + END; + END; + +-- CASE D2: COMPONENT IS ABSENT + + SEQUENCE_NUMBER := 2; + DECLARE + TYPE CONS (D3 : INTEGER := IDENT_INT(11)) IS + RECORD + CASE D3 IS + WHEN -5..10 => + C1 : MY_ARR(IDENT_INT(2)..D3); + WHEN OTHERS => + C2 : INTEGER := IDENT_INT(5); + END CASE; + END RECORD; + BEGIN + BEGIN + DECLARE + X : CONS; + BEGIN + IF X /= (11, 5) THEN + COMMENT ("X VALUE IS INCORRECT - 11"); + END IF; + END; + EXCEPTION + WHEN CONSTRAINT_ERROR => + NULL; + WHEN OTHERS => + FAILED ("UNEXPECTED EXCEPTION RAISED - 11"); + END; + + BEGIN + DECLARE + SUBTYPE SCONS IS CONS; + BEGIN + DECLARE + X : SCONS; + BEGIN + IF X /= (11, 5) THEN + FAILED ("X VALUE INCORRECT - 12"); + END IF; + END; + EXCEPTION + WHEN OTHERS => + FAILED ("UNEXPECTED EXCEPTION RAISED - 12A"); + END; + EXCEPTION + WHEN OTHERS => + FAILED ("UNEXPECTED EXCEPTION RAISED - 12B"); + END; + + BEGIN + DECLARE + TYPE ARR IS ARRAY (1..5) OF CONS; + BEGIN + DECLARE + X : ARR; + BEGIN + IF X /= (1..5 => (11, 5)) THEN + FAILED ("X VALUE INCORRECT - 13"); + END IF; + END; + EXCEPTION + WHEN OTHERS => + FAILED ("UNEXPECTED EXCEPTION RAISED - 13A"); + END; + EXCEPTION + WHEN OTHERS => + FAILED ("UNEXPECTED EXCEPTION RAISED - 13B"); + END; + + BEGIN + DECLARE + TYPE NREC IS + RECORD + C1 : CONS; + END RECORD; + BEGIN + DECLARE + X : NREC; + BEGIN + IF X /= (C1 => (11, 5)) THEN + FAILED ("X VALUE INCORRECT - 14"); + END IF; + END; + EXCEPTION + WHEN OTHERS => + FAILED ("UNEXPECTED EXCEPTION RAISED - 14A"); + END; + EXCEPTION + WHEN OTHERS => + FAILED ("UNEXPECTED EXCEPTION RAISED - 14B"); + END; + + BEGIN + DECLARE + TYPE NREC IS NEW CONS; + BEGIN + DECLARE + X : NREC; + BEGIN + IF X /= (11, 5) THEN + FAILED ("X VALUE INCORRECT - 15"); + END IF; + END; + EXCEPTION + WHEN OTHERS => + FAILED ("UNEXPECTED EXCEPTION RAISED - 15A"); + END; + EXCEPTION + WHEN OTHERS => + FAILED ("UNEXPECTED EXCEPTION RAISED - 15B"); + END; + + BEGIN + DECLARE + TYPE ACC_CONS IS ACCESS CONS; + X : ACC_CONS; + BEGIN + X := NEW CONS; + IF X.ALL /= (11, 5) THEN + FAILED ("X VALUE INCORRECT - 17"); + END IF; + EXCEPTION + WHEN OTHERS => + FAILED ("UNEXPECTED EXCEPTION RAISED - 17A"); + END; + EXCEPTION + WHEN OTHERS => + FAILED ("UNEXPECTED EXCEPTION RAISED - 17B"); + END; + END; + + RESULT; +EXCEPTION + WHEN OTHERS => + FAILED ("INDEX VALUES CHECKED TOO SOON - " & + INTEGER'IMAGE(SEQUENCE_NUMBER)); + RESULT; +END C37215H; diff --git a/gcc-4.9/gcc/testsuite/ada/acats/tests/c3/c37217a.ada b/gcc-4.9/gcc/testsuite/ada/acats/tests/c3/c37217a.ada new file mode 100644 index 000000000..bf0a9b4b4 --- /dev/null +++ b/gcc-4.9/gcc/testsuite/ada/acats/tests/c3/c37217a.ada @@ -0,0 +1,128 @@ +-- C37217A.ADA + +-- Grant of Unlimited Rights +-- +-- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687, +-- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained +-- unlimited rights in the software and documentation contained herein. +-- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making +-- this public release, the Government intends to confer upon all +-- recipients unlimited rights equal to those held by the Government. +-- These rights include rights to use, duplicate, release or disclose the +-- released technical data and computer software in whole or in part, in +-- any manner and for any purpose whatsoever, and to have or permit others +-- to do so. +-- +-- DISCLAIMER +-- +-- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR +-- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED +-- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF 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 WHETHER THE OPTIONAL COMPATIBILITY CHECK IS +-- PERFORMED WHEN A DISCRIMINANT CONSTRAINT IS GIVEN FOR AN ACCESS +-- TYPE - AFTER THE TYPE'S FULL DECLARATION. + +-- HISTORY: +-- DHH 02/05/88 CREATED ORIGINAL TEST. + +WITH REPORT; USE REPORT; +PROCEDURE C37217A IS + + SUBTYPE SM IS INTEGER RANGE 1..10; + +BEGIN --C37217A BODY + TEST ("C37217A", "CHECK WHETHER THE OPTIONAL COMPATIBILITY " & + "CHECK IS PERFORMED WHEN A DISCRIMINANT " & + "CONSTRAINT IS GIVEN FOR AN ACCESS TYPE " & + "- AFTER THE TYPE'S FULL DECLARATION"); + + -- CHECK FULL DECLARATION + -- LOWER LIMIT + BEGIN + DECLARE + + TYPE SM_REC(D : SM) IS + RECORD + NULL; + END RECORD; + + TYPE REC(D1 : INTEGER) IS + RECORD + INT : SM_REC(D1); + END RECORD; + + TYPE PTR IS ACCESS REC; + + Y : PTR(IDENT_INT(0)); -- OPTIONAL EXCEPTION. + BEGIN + COMMENT("OPTIONAL COMBATIBILITY CHECK NOT PERFORMED " & + "- LOWER"); + Y := NEW REC(IDENT_INT(0)); -- MANDATORY EXCEPTION. + FAILED("CONSTRAINT ERROR NOT RAISED"); + + IF IDENT_INT(Y.INT.D) /= IDENT_INT(-1) THEN + COMMENT ("IRRELEVANT"); + END IF; + EXCEPTION + WHEN CONSTRAINT_ERROR => + NULL; + WHEN OTHERS => + FAILED("UNEXPECTED EXCEPTION RAISED IN " & + "VARIABLE ALLOCATION - LOWER"); + END; + EXCEPTION + WHEN CONSTRAINT_ERROR => + COMMENT("OPTIONAL CONSTRAINT ERROR RAISED - LOWER"); + WHEN OTHERS => + FAILED("UNEXPECTED EXCEPTION RAISED IN " & + "VARIABLE DECLARATION - LOWER"); + END; +--------------------------------------------------------------------- + -- CHECK FULL DECLARATION + -- UPPER LIMIT + BEGIN + DECLARE + TYPE SM_ARR IS ARRAY(SM RANGE <>) OF INTEGER; + + TYPE REC(D1 : INTEGER) IS + RECORD + INT : SM_ARR(1 .. D1); + END RECORD; + + TYPE PTR IS ACCESS REC; + + Y : PTR(IDENT_INT(11)); -- OPTIONAL EXCEPTION. + BEGIN + COMMENT("OPTIONAL COMBATIBILITY CHECK NOT PERFORMED " & + "- UPPER"); + Y := NEW REC'(IDENT_INT(11), -- MANDATORY EXCEPTION. + INT => (OTHERS => IDENT_INT(0))); + FAILED("CONSTRAINT ERROR NOT RAISED"); + + IF IDENT_INT(Y.INT(IDENT_INT(1))) /= 11 THEN + COMMENT ("IRRELEVANT"); + END IF; + EXCEPTION + WHEN CONSTRAINT_ERROR => + NULL; + WHEN OTHERS => + FAILED("UNEXPECTED EXCEPTION RAISED IN " & + "VARIABLE ALLOCATION - UPPER"); + END; + EXCEPTION + WHEN CONSTRAINT_ERROR => + COMMENT("OPTIONAL COMPATIBILITY CHECK PERFORMED " & + "- UPPER"); + WHEN OTHERS => + FAILED("UNEXPECTED EXCEPTION RAISED IN " & + "VARIABLE DECLARATION - UPPER"); + END; + + RESULT; + +END C37217A; -- BODY diff --git a/gcc-4.9/gcc/testsuite/ada/acats/tests/c3/c37217b.ada b/gcc-4.9/gcc/testsuite/ada/acats/tests/c3/c37217b.ada new file mode 100644 index 000000000..77a9d8996 --- /dev/null +++ b/gcc-4.9/gcc/testsuite/ada/acats/tests/c3/c37217b.ada @@ -0,0 +1,132 @@ +-- C37217B.ADA + +-- Grant of Unlimited Rights +-- +-- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687, +-- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained +-- unlimited rights in the software and documentation contained herein. +-- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making +-- this public release, the Government intends to confer upon all +-- recipients unlimited rights equal to those held by the Government. +-- These rights include rights to use, duplicate, release or disclose the +-- released technical data and computer software in whole or in part, in +-- any manner and for any purpose whatsoever, and to have or permit others +-- to do so. +-- +-- DISCLAIMER +-- +-- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR +-- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED +-- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF 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 WHETHER THE OPTIONAL COMPATIBILITY CHECK IS +-- PERFORMED WHEN A DISCRIMINANT CONSTRAINT IS GIVEN FOR AN ACCESS +-- TYPE - BEFORE THE DESIGNATED TYPE'S FULL DECLARATION. + +-- HISTORY: +-- DHH 08/04/88 CREATED ORIGINAL TEST. + +WITH REPORT; USE REPORT; +PROCEDURE C37217B IS + + SUBTYPE SM IS INTEGER RANGE 1..10; + +BEGIN --C37217B BODY + TEST ("C37217B", "CHECK WHETHER THE OPTIONAL COMPATIBILITY " & + "CHECK IS PERFORMED WHEN A DISCRIMINANT " & + "CONSTRAINT IS GIVEN FOR AN ACCESS TYPE - " & + "BEFORE THE DESIGNATED TYPE'S FULL DECLARATION"); + +--------------------------------------------------------------------- + -- INCOMPLETE DECLARATION + -- UPPER LIMIT + BEGIN -- F + DECLARE -- F + TYPE REC(D1 : INTEGER); + + TYPE PTR IS ACCESS REC; + X : PTR(IDENT_INT(11)); + + TYPE SM_REC(D : SM) IS + RECORD + NULL; + END RECORD; + + TYPE REC(D1 : INTEGER) IS + RECORD + INT : SM_REC(D1); + END RECORD; + BEGIN + COMMENT("OPTIONAL COMPATIBILITY CHECK NOT PERFORMED " & + "- UPPER"); + X := NEW REC(IDENT_INT(11)); + FAILED("CONSTRAINT ERROR NOT RAISED - UPPER"); + + IF IDENT_INT(X.INT.D) /= IDENT_INT(1) THEN + COMMENT("IRREVELANT"); + END IF; + EXCEPTION + WHEN CONSTRAINT_ERROR => + NULL; + WHEN OTHERS => + FAILED("UNEXPECTED EXCEPTION RAISED IN " & + "VARIABLE USE - INCOMPLETE UPPER"); + END; + EXCEPTION + WHEN CONSTRAINT_ERROR => + COMMENT("OPTIONAL COMPATIBILITY CHECK PERFORMED " & + "- INCOMPLETE UPPER"); + WHEN OTHERS => + FAILED("UNEXPECTED EXCEPTION RAISED IN " & + "VARIABLE DECLARATION - INCOMPLETE UPPER"); + END; -- F + +----------------------------------------------------------------------- + -- INCOMPLETE DECLARATION + -- LOWER LIMIT + BEGIN -- A + DECLARE -- A + TYPE REC(D1 : INTEGER); + + TYPE PTR IS ACCESS REC; + X : PTR(IDENT_INT(0)); + + TYPE SM_ARR IS ARRAY(SM RANGE <>) OF INTEGER; + + TYPE REC(D1 : INTEGER) IS + RECORD + INT : SM_ARR(D1 .. 2); + END RECORD; + BEGIN + COMMENT("OPTIONAL COMPATIBILITY CHECK NOT PERFORMED " & + "- LOWER"); + X := NEW REC'(IDENT_INT(0), INT => + (OTHERS => IDENT_INT(1))); + FAILED("CONSTRAINT ERROR NOT RAISED - LOWER"); + + IF X.INT(IDENT_INT(1)) /= IDENT_INT(1) THEN + COMMENT("IRREVELANT"); + END IF; + EXCEPTION + WHEN CONSTRAINT_ERROR => + NULL; + WHEN OTHERS => + FAILED("UNEXPECTED EXCEPTION RAISED IN " & + "VARIABLE USE - INCOMPLETE LOWER"); + END; + EXCEPTION + WHEN CONSTRAINT_ERROR => + COMMENT("OPTIONAL COMPATIBILITY CHECK PERFORMED " & + "- INCOMPLETE LOWER"); + WHEN OTHERS => + FAILED("UNEXPECTED EXCEPTION RAISED IN " & + "VARIABLE DECLARATION - INCOMPLETE LOWER"); + END; +----------------------------------------------------------------------- + RESULT; + +END C37217B; -- BODY diff --git a/gcc-4.9/gcc/testsuite/ada/acats/tests/c3/c37217c.ada b/gcc-4.9/gcc/testsuite/ada/acats/tests/c3/c37217c.ada new file mode 100644 index 000000000..f6fee5c17 --- /dev/null +++ b/gcc-4.9/gcc/testsuite/ada/acats/tests/c3/c37217c.ada @@ -0,0 +1,100 @@ +-- C37217C.ADA + +-- Grant of Unlimited Rights +-- +-- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687, +-- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained +-- unlimited rights in the software and documentation contained herein. +-- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making +-- this public release, the Government intends to confer upon all +-- recipients unlimited rights equal to those held by the Government. +-- These rights include rights to use, duplicate, release or disclose the +-- released technical data and computer software in whole or in part, in +-- any manner and for any purpose whatsoever, and to have or permit others +-- to do so. +-- +-- DISCLAIMER +-- +-- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR +-- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED +-- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF 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 WHETHER THE OPTIONAL COMPATIBILITY CHECK IS +-- PERFORMED WHEN A DISCRIMINANT CONSTRAINT IS GIVEN FOR AN ACCESS +-- TYPE - WHEN THERE IS A "LOOP" IN THE DESIGNATED TYPE'S FULL +-- DECLARATION. + +-- HISTORY: +-- DHH 08/04/88 CREATED ORIGINAL TEST. + +WITH REPORT; USE REPORT; +PROCEDURE C37217C IS + +BEGIN --C37217C BODY + TEST ("C37217C", "CHECK WHETHER THE OPTIONAL COMPATIBILITY " & + "CHECK IS PERFORMED WHEN A DISCRIMINANT " & + "CONSTRAINT IS GIVEN FOR AN ACCESS TYPE " & + "- WHEN THERE IS A ""LOOP"" IN THE DESIGNATED " & + "TYPE'S FULL DECLARATION"); + + BEGIN + DECLARE + TYPE R1(D1 : INTEGER); + TYPE R2(D2 : INTEGER); + TYPE R3(D3 : POSITIVE); + + TYPE ACC_R1 IS ACCESS R1; + TYPE ACC_R2 IS ACCESS R2; + TYPE ACC_R3 IS ACCESS R3; + + TYPE R1(D1 : INTEGER) IS + RECORD + C1 : ACC_R2(D1); + END RECORD; + + TYPE R2(D2 : INTEGER) IS + RECORD + C2 : ACC_R3(D2); + END RECORD; + + TYPE R3(D3 : POSITIVE) IS + RECORD + C3 : ACC_R1(D3); + END RECORD; + + X1 : ACC_R1(IDENT_INT(0)); + + BEGIN + COMMENT("OPTIONAL COMPATIBILITY CHECK NOT PERFORMED"); + + X1 := NEW R1'(D1 =>IDENT_INT(0), + C1 => NEW R2'(D2 => IDENT_INT(0), + C2 => NEW R3(IDENT_INT(0)))); + + FAILED("CONSTRAINT_ERROR NOT RAISED"); + + IF IDENT_INT(X1.C1.C2.D3) /= IDENT_INT(0) THEN + COMMENT("THIS LINE SHOULD NOT PRINT OUT"); + END IF; + EXCEPTION + WHEN CONSTRAINT_ERROR => + NULL; + WHEN OTHERS => + FAILED("UNEXPECTED EXCEPTION RAISED IN " & + "VARIABLE USE - LOOPED"); + END; + EXCEPTION + WHEN CONSTRAINT_ERROR => + COMMENT("OPTIONAL COMPATIBILITY CHECK PERFORMED"); + WHEN OTHERS => + FAILED("UNEXPECTED EXCEPTION RAISED IN " & + "VARIABLE DECLARATION - LOOPED"); + END; + + RESULT; + +END C37217C; -- BODY diff --git a/gcc-4.9/gcc/testsuite/ada/acats/tests/c3/c37304a.ada b/gcc-4.9/gcc/testsuite/ada/acats/tests/c3/c37304a.ada new file mode 100644 index 000000000..e521671e2 --- /dev/null +++ b/gcc-4.9/gcc/testsuite/ada/acats/tests/c3/c37304a.ada @@ -0,0 +1,92 @@ +-- C37304A.ADA + +-- Grant of Unlimited Rights +-- +-- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687, +-- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained +-- unlimited rights in the software and documentation contained herein. +-- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making +-- this public release, the Government intends to confer upon all +-- recipients unlimited rights equal to those held by the Government. +-- These rights include rights to use, duplicate, release or disclose the +-- released technical data and computer software in whole or in part, in +-- any manner and for any purpose whatsoever, and to have or permit others +-- to do so. +-- +-- DISCLAIMER +-- +-- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR +-- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED +-- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF 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 ALL FORMS OF CHOICE ARE PERMITTED IN A VARIANT_PART, +-- AND, IN PARTICULAR, THAT FORMS LIKE ST RANGE L..R, AND ST ARE +-- PERMITTED. + +-- ASL 7/31/81 +-- RM 8/26/82 +-- SPS 1/21/83 + +WITH REPORT; +PROCEDURE C37304A IS + + USE REPORT; + +BEGIN + + TEST("C37304A","ALL FORMS OF CHOICE ALLOWED IN A VARIANT_PART"); + + DECLARE + + 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; + + TYPE VREC( DISC : T := 8 ) IS + RECORD + CASE DISC IS + WHEN SN -- 9..8 + | S1 RANGE 1 .. 0 -- 1..0 + | S2 RANGE C5 + 2 .. C5 + 1 -- 7..6 + | 3 .. 2 -- 3..2 + => NULL; + + 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 + => NULL; + + WHEN C5 + C5 - 2 .. 8 -- 8 + => NULL; + + END CASE; + END RECORD; + + V : VREC; + + BEGIN + + IF EQUAL(3,3) THEN + V := (DISC => 5); + END IF; + IF V.DISC /= 5 THEN + FAILED ("ASSIGNMENT FAILED"); + END IF; + + END; + + RESULT; + +END C37304A; diff --git a/gcc-4.9/gcc/testsuite/ada/acats/tests/c3/c37305a.ada b/gcc-4.9/gcc/testsuite/ada/acats/tests/c3/c37305a.ada new file mode 100644 index 000000000..0282fa90e --- /dev/null +++ b/gcc-4.9/gcc/testsuite/ada/acats/tests/c3/c37305a.ada @@ -0,0 +1,82 @@ +-- C37305A.ADA + +-- Grant of Unlimited Rights +-- +-- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687, +-- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained +-- unlimited rights in the software and documentation contained herein. +-- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making +-- this public release, the Government intends to confer upon all +-- recipients unlimited rights equal to those held by the Government. +-- These rights include rights to use, duplicate, release or disclose the +-- released technical data and computer software in whole or in part, in +-- any manner and for any purpose whatsoever, and to have or permit others +-- to do so. +-- +-- DISCLAIMER +-- +-- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR +-- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED +-- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF 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 CHOICES DENOTING A NULL RANGE OF VALUES ARE PERMITTED, +-- AND THAT FOR CHOICES CONSISTING OF A SUBTYPE NAME FOLLOWED BY A +-- RANGE CONSTRAINT WHERE THE LOWER BOUND IS GREATER THAN THE UPPER +-- BOUND, THE BOUNDS NEED NOT BE IN THE RANGE OF THE SUBTYPE VALUES. + +-- CHECK THAT AN OTHERS ALTERNATIVE CAN BE PROVIDED EVEN IF ALL VALUES +-- OF THE CASE EXPRESSION HAVE BEEN COVERED BY PRECEDING ALTERNATIVES. + +-- ASL 7/14/81 +-- JWC 6/28/85 RENAMED TO -AB + +WITH REPORT; +PROCEDURE C37305A IS + + USE REPORT; + +BEGIN + TEST ("C37305A","NULL RANGES ALLOWED IN CHOICES FOR VARIANT " & + "PARTS. OTHERS ALTERNATIVE ALLOWED AFTER ALL VALUES " & + "PREVIOUSLY COVERED"); + + DECLARE + SUBTYPE ST IS INTEGER RANGE 1..10; + + TYPE REC(DISC : ST := 1) IS + RECORD + CASE DISC IS + WHEN 0..-1 => NULL; + WHEN 1..-3 => NULL; + WHEN 6..5 => + COMP : INTEGER; + WHEN 11..10 => NULL; + WHEN 15..12 => NULL; + WHEN 11..0 => NULL; + WHEN 1..10 => NULL; + WHEN OTHERS => NULL; + END CASE; + END RECORD; + + R : REC; + BEGIN + R := (DISC => 4); + + IF EQUAL(3,4) THEN + R := (DISC => 7); + END IF; + + IF R.DISC /= 4 THEN + FAILED ("ASSIGNMENT FAILED"); + END IF; + EXCEPTION + WHEN OTHERS => + FAILED ("EXCEPTION RAISED"); + END; + + RESULT; + +END C37305A; diff --git a/gcc-4.9/gcc/testsuite/ada/acats/tests/c3/c37306a.ada b/gcc-4.9/gcc/testsuite/ada/acats/tests/c3/c37306a.ada new file mode 100644 index 000000000..f50fe0195 --- /dev/null +++ b/gcc-4.9/gcc/testsuite/ada/acats/tests/c3/c37306a.ada @@ -0,0 +1,70 @@ +-- C37306A.ADA + +-- Grant of Unlimited Rights +-- +-- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687, +-- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained +-- unlimited rights in the software and documentation contained herein. +-- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making +-- this public release, the Government intends to confer upon all +-- recipients unlimited rights equal to those held by the Government. +-- These rights include rights to use, duplicate, release or disclose the +-- released technical data and computer software in whole or in part, in +-- any manner and for any purpose whatsoever, and to have or permit others +-- to do so. +-- +-- DISCLAIMER +-- +-- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR +-- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED +-- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF 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 IN A VARIANT PART OF A RECORD THE CHOICES WITHIN AND +-- BETWEEN ALTERNATIVES CAN APPEAR IN NON-MONOTONIC ORDER. + +-- ASL 7/13/81 +-- JWC 6/28/85 RENAMED TO -AB + +WITH REPORT; +PROCEDURE C37306A IS + + USE REPORT; + +BEGIN + TEST ("C37306A","NON-MONOTONIC ORDER OF CHOICES IN VARIANT PARTS"); + + DECLARE + TYPE COLOR IS (WHITE,RED,ORANGE,YELLOW,GREEN,AQUA,BLUE,BLACK); + + TYPE REC(DISC : COLOR := BLUE) IS + RECORD + CASE DISC IS + WHEN ORANGE => NULL; + WHEN GREEN | WHITE | BLACK => NULL; + WHEN YELLOW => NULL; + WHEN BLUE | RED => NULL; + WHEN OTHERS => NULL; + END CASE; + END RECORD; + + R : REC; + BEGIN + R := (DISC => WHITE); + + IF EQUAL(3,4) THEN + R := (DISC => RED); + END IF; + + IF R.DISC /= WHITE THEN + FAILED ("ASSIGNMENT FAILED"); + END IF; + EXCEPTION + WHEN OTHERS => + FAILED ("EXCEPTION RAISED"); + END; + + RESULT; +END C37306A; diff --git a/gcc-4.9/gcc/testsuite/ada/acats/tests/c3/c37309a.ada b/gcc-4.9/gcc/testsuite/ada/acats/tests/c3/c37309a.ada new file mode 100644 index 000000000..316c0e8a8 --- /dev/null +++ b/gcc-4.9/gcc/testsuite/ada/acats/tests/c3/c37309a.ada @@ -0,0 +1,74 @@ +-- C37309A.ADA + +-- Grant of Unlimited Rights +-- +-- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687, +-- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained +-- unlimited rights in the software and documentation contained herein. +-- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making +-- this public release, the Government intends to confer upon all +-- recipients unlimited rights equal to those held by the Government. +-- These rights include rights to use, duplicate, release or disclose the +-- released technical data and computer software in whole or in part, in +-- any manner and for any purpose whatsoever, and to have or permit others +-- to do so. +-- +-- DISCLAIMER +-- +-- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR +-- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED +-- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF 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 DISCRIMINANT HAS A STATIC SUBTYPE, AN OTHERS +-- CHOICE CAN BE OMITTED IF ALL VALUES IN THE +-- SUBTYPE'S RANGE ARE COVERED IN A VARIANT PART. + +-- ASL 7/10/81 +-- SPS 10/25/82 +-- SPS 7/17/83 + +WITH REPORT; +PROCEDURE C37309A IS + + USE REPORT; + +BEGIN + TEST ("C37309A","OTHERS CHOICE CAN BE OMITTED IN VARIANT PART " & + "IF ALL VALUES IN STATIC SUBTYPE RANGE OF DISCRIMINANT " & + "ARE COVERED"); + + DECLARE + SUBTYPE STATCHAR IS CHARACTER RANGE 'I'..'N'; + TYPE REC1(DISC : STATCHAR := 'J') IS + RECORD + CASE DISC IS + WHEN 'I' => NULL; + WHEN 'J' => NULL; + WHEN 'K' => NULL; + WHEN 'L' => NULL; + WHEN 'M' => NULL; + WHEN 'N' => NULL; + END CASE; + END RECORD; + + R1 : REC1; + BEGIN + R1 := (DISC => 'N'); + IF EQUAL(3,3) THEN + R1 := (DISC => 'K'); + END IF; + IF R1.DISC /= 'K' THEN + FAILED ("ASSIGNMENT FAILED - 1"); + END IF; + + EXCEPTION + WHEN OTHERS => + FAILED ("EXCEPTION RAISED"); + END; + + RESULT; + +END C37309A; diff --git a/gcc-4.9/gcc/testsuite/ada/acats/tests/c3/c37310a.ada b/gcc-4.9/gcc/testsuite/ada/acats/tests/c3/c37310a.ada new file mode 100644 index 000000000..dfa3748a9 --- /dev/null +++ b/gcc-4.9/gcc/testsuite/ada/acats/tests/c3/c37310a.ada @@ -0,0 +1,124 @@ +-- C37310A.ADA + +-- Grant of Unlimited Rights +-- +-- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687, +-- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained +-- unlimited rights in the software and documentation contained herein. +-- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making +-- this public release, the Government intends to confer upon all +-- recipients unlimited rights equal to those held by the Government. +-- These rights include rights to use, duplicate, release or disclose the +-- released technical data and computer software in whole or in part, in +-- any manner and for any purpose whatsoever, and to have or permit others +-- to do so. +-- +-- DISCLAIMER +-- +-- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR +-- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED +-- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF 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 DISCRIMINANT HAS A DYNAMIC SUBTYPE, AN OTHERS +-- CHOICE CAN BE OMITTED IF ALL VALUES IN THE BASE +-- TYPE'S RANGE ARE COVERED. + +-- ASL 7/10/81 +-- SPS 10/25/82 +-- PWN 01/31/95 REMOVED INCONSISTENCIES WITH ADA 9X. + +WITH REPORT; +PROCEDURE C37310A IS + + USE REPORT; + +BEGIN + TEST ("C37310A", "CHECK DYNAMIC DISCRIMINANT SUBTYPES " & + "IN VARIANT RECORD DECLARATIONS"); + + DECLARE + + ACHAR : CHARACTER := IDENT_CHAR('A'); + ECHAR : CHARACTER := IDENT_CHAR('E'); + JCHAR : CHARACTER := IDENT_CHAR('J'); + MCHAR : CHARACTER := IDENT_CHAR('M'); + SUBTYPE STATCHAR IS CHARACTER RANGE 'I'..'N'; + SUBTYPE DYNCHAR IS CHARACTER RANGE ACHAR..ECHAR; + SUBTYPE SSTAT IS STATCHAR RANGE JCHAR..MCHAR; + + TYPE LETTER IS NEW CHARACTER RANGE 'A'..'Z'; + SUBTYPE DYNLETTER IS + LETTER RANGE LETTER(ECHAR)..LETTER(JCHAR); + + TYPE REC1(DISC : SSTAT := 'K') IS + RECORD + CASE DISC IS + WHEN ASCII.NUL..CHARACTER'LAST => NULL; + END CASE; + END RECORD; + + TYPE REC2(DISC : DYNCHAR := 'C') IS + RECORD + CASE DISC IS + WHEN ASCII.NUL..CHARACTER'LAST => NULL; + END CASE; + END RECORD; + + TYPE REC3(DISC: DYNCHAR := 'D') IS + RECORD + CASE DISC IS + WHEN CHARACTER'FIRST..CHARACTER'LAST => NULL; + END CASE; + END RECORD; + + TYPE REC4(DISC : DYNLETTER := 'F') IS + RECORD + CASE DISC IS + WHEN LETTER'BASE'FIRST.. + LETTER'BASE'LAST => NULL; + END CASE; + END RECORD; + + R1 : REC1; + R2 : REC2; + R3 : REC3; + R4 : REC4; + BEGIN + IF EQUAL(3,3) THEN + R1 := (DISC => 'L'); + END IF; + IF R1.DISC /= 'L' THEN + FAILED ("ASSIGNMENT FAILED - 1"); + END IF; + + IF EQUAL(3,3) THEN + R2 := (DISC => 'B'); + END IF; + IF R2.DISC /= 'B' THEN + FAILED ("ASSIGNMENT FAILED - 2"); + END IF; + + IF EQUAL(3,3) THEN + R3 := (DISC => 'B'); + END IF; + IF R3.DISC /= 'B' THEN + FAILED ("ASSIGNMENT FAILED - 3"); + END IF; + + IF EQUAL(3,3) THEN + R4 := (DISC => 'H'); + END IF; + IF R4.DISC /= 'H' THEN + FAILED ("ASSIGNMENT FAILED - 4"); + END IF; + EXCEPTION + WHEN OTHERS => + FAILED ("EXCEPTION RAISED"); + END; + + RESULT; + +END C37310A; diff --git a/gcc-4.9/gcc/testsuite/ada/acats/tests/c3/c37312a.ada b/gcc-4.9/gcc/testsuite/ada/acats/tests/c3/c37312a.ada new file mode 100644 index 000000000..f34eb7cb3 --- /dev/null +++ b/gcc-4.9/gcc/testsuite/ada/acats/tests/c3/c37312a.ada @@ -0,0 +1,87 @@ +-- C37312A.ADA + +-- Grant of Unlimited Rights +-- +-- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687, +-- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained +-- unlimited rights in the software and documentation contained herein. +-- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making +-- this public release, the Government intends to confer upon all +-- recipients unlimited rights equal to those held by the Government. +-- These rights include rights to use, duplicate, release or disclose the +-- released technical data and computer software in whole or in part, in +-- any manner and for any purpose whatsoever, and to have or permit others +-- to do so. +-- +-- DISCLAIMER +-- +-- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR +-- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED +-- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF 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 DISCRIMINANT CAN HAVE A GENERIC FORMAL DISCRETE +-- TYPE WHEN IT DOES NOT GOVERN A VARIANT PART AND THAT AN +-- OBJECT OF A GENERIC FORMAL TYPE CAN CONSTRAIN A COMPONENT +-- IN A VARIANT PART. + +-- HISTORY: +-- AH 08/22/86 CREATED ORIGINAL TEST. +-- JET 08/13/87 REVISED FROM CLASS 'A' TO CLASS 'C' TEST. + +WITH REPORT; USE REPORT; + +PROCEDURE C37312A IS + +BEGIN + TEST ("C37312A", "DISCRIMINANT TYPE IS GENERIC FORMAL TYPE"); + + DECLARE + TYPE T IS RANGE 1 ..5; + + GENERIC + TYPE G1 IS RANGE <>; + PACKAGE P IS + TYPE G2 (D1 : G1) IS + RECORD + R1 : G1; + R2 : BOOLEAN; + END RECORD; + + TYPE STR IS ARRAY(G1 RANGE <>) OF INTEGER; + TYPE G3 (D : G1; E : INTEGER) IS + RECORD + CASE E IS + WHEN 1 => + S1 : STR(G1'FIRST..D); + WHEN OTHERS => + S2 : INTEGER; + END CASE; + END RECORD; + + END P; + + PACKAGE PKG IS NEW P (G1 => T); + USE PKG; + + A2: G2(1) := (1, 5, FALSE); + A3: G3(5, 1) := (5, 1, (1, 2, 3, 4, 5)); + + BEGIN + A2.R2 := IDENT_BOOL (TRUE); + A3.S1(1) := IDENT_INT (6); + + IF A2 /= (1, 5, TRUE) THEN + FAILED ("INVALID CONTENTS OF RECORD A2"); + END IF; + IF A3 /= (5, 1, (6, 2, 3, 4, 5)) THEN + FAILED ("INVALID CONTENTS OF RECORD A3"); + END IF; + END; + + RESULT; + +END C37312A; diff --git a/gcc-4.9/gcc/testsuite/ada/acats/tests/c3/c37402a.ada b/gcc-4.9/gcc/testsuite/ada/acats/tests/c3/c37402a.ada new file mode 100644 index 000000000..ec21d745f --- /dev/null +++ b/gcc-4.9/gcc/testsuite/ada/acats/tests/c3/c37402a.ada @@ -0,0 +1,253 @@ +-- C37402A.ADA + +-- Grant of Unlimited Rights +-- +-- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687, +-- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained +-- unlimited rights in the software and documentation contained herein. +-- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making +-- this public release, the Government intends to confer upon all +-- recipients unlimited rights equal to those held by the Government. +-- These rights include rights to use, duplicate, release or disclose the +-- released technical data and computer software in whole or in part, in +-- any manner and for any purpose whatsoever, and to have or permit others +-- to do so. +-- +-- DISCLAIMER +-- +-- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR +-- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED +-- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF 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 FORMAL PARAMETER OF A SUBPROGRAM, ENTRY, OR +-- GENERIC UNIT HAS AN UNCONSTRAINED TYPE WITH DISCRIMINANTS THAT +-- HAVE DEFAULTS, 'CONSTRAINED IS 'TRUE' WHEN APPLIED TO FORMAL +-- PARAMETERS OF MODE IN AND HAS THE VALUE OF THE ACTUAL PARAMETER +-- FOR THE OTHER MODES. + +-- R.WILLIAMS 9/1/86 + +WITH REPORT; USE REPORT; +PROCEDURE C37402A IS + +BEGIN + TEST ( "C37402A", "CHECK THAT WHEN A FORMAL PARAMETER OF A " & + "SUBPROGRAM, ENTRY, OR GENERIC UNIT HAS AN " & + "UNCONSTRAINED TYPE WITH DISCRIMINANTS THAT " & + "HAVE DEFAULTS, 'CONSTRAINED IS 'TRUE' WHEN " & + "APPLIED TO FORMAL PARAMETERS OF MODE IN " & + "AND HAS THE VALUE OF THE ACTUAL PARAMETER " & + "FOR THE OTHER MODES" ); + + + DECLARE + + SUBTYPE INT IS INTEGER RANGE 1 .. 5; + + TYPE MATRIX IS ARRAY (INT RANGE <>, INT RANGE <>) + OF INTEGER; + + TYPE SQUARE (SIDE : INT := 1) IS + RECORD + MAT : MATRIX (1 .. SIDE, 1 .. SIDE); + END RECORD; + + SC : CONSTANT SQUARE := (2, ((0, 0), (0, 0))); + + AC : SQUARE (2) := (2, ((1, 2), (3, 4))); + AU : SQUARE := (SIDE => 1, MAT => (1 => (1 => 1))); + + BC : SQUARE (2) := AC; + BU : SQUARE := AU; + + CC : SQUARE (2); + CU : SQUARE; + + PROCEDURE P (CON, IN_CON : IN SQUARE; + INOUT_CON : IN OUT SQUARE; + OUT_CON : OUT SQUARE; + IN_UNC : IN SQUARE; + INOUT_UNC : IN OUT SQUARE; + OUT_UNC : OUT SQUARE) IS + + BEGIN + IF CON'CONSTRAINED THEN + NULL; + ELSE + FAILED ( "'CONSTRAINED IS 'FALSE' FOR OBJECT " & + "OF IN MODE - 1" ); + END IF; + + IF IN_CON'CONSTRAINED THEN + NULL; + ELSE + FAILED ( "'CONSTRAINED IS 'FALSE' FOR OBJECT " & + "OF IN MODE - 2" ); + END IF; + + IF IN_UNC'CONSTRAINED THEN + NULL; + ELSE + FAILED ( "'CONSTRAINED IS 'FALSE' FOR OBJECT " & + "OF IN MODE - 3" ); + END IF; + + IF INOUT_CON'CONSTRAINED THEN + NULL; + ELSE + FAILED ( "'CONSTRAINED IS 'FALSE' FOR " & + "CONSTRAINED OBJECT OF IN OUT MODE - 1" ); + END IF; + + IF OUT_CON'CONSTRAINED THEN + NULL; + ELSE + FAILED ( "'CONSTRAINED IS 'FALSE' FOR " & + "CONSTRAINED OBJECT OF OUT MODE - 1" ); + END IF; + + IF INOUT_UNC'CONSTRAINED THEN + FAILED ( "'CONSTRAINED IS 'TRUE' FOR " & + "UNCONSTRAINED OBJECT OF IN OUT MODE " & + "- 1" ); + END IF; + + IF OUT_UNC'CONSTRAINED THEN + FAILED ( "'CONSTRAINED IS 'TRUE' FOR " & + "UNCONSTRAINED OBJECT OF OUT MODE - 1" ); + END IF; + + OUT_CON := (2, ((1, 2), (3, 4))); + OUT_UNC := (2, ((1, 2), (3, 4))); + END P; + + TASK T IS + ENTRY Q (CON, IN_CON : IN SQUARE; + INOUT_CON : IN OUT SQUARE; + OUT_CON : OUT SQUARE; + IN_UNC : IN SQUARE; + INOUT_UNC : IN OUT SQUARE; + OUT_UNC : OUT SQUARE); + END T; + + TASK BODY T IS + BEGIN + ACCEPT Q (CON, IN_CON : IN SQUARE; + INOUT_CON : IN OUT SQUARE; + OUT_CON : OUT SQUARE; + IN_UNC : IN SQUARE; + INOUT_UNC : IN OUT SQUARE; + OUT_UNC : OUT SQUARE) DO + BEGIN + IF CON'CONSTRAINED THEN + NULL; + ELSE + FAILED ( "'CONSTRAINED IS 'FALSE' FOR " & + "OBJECT OF IN MODE - 4" ); + END IF; + + IF IN_CON'CONSTRAINED THEN + NULL; + ELSE + FAILED ( "'CONSTRAINED IS 'FALSE' FOR " & + "OBJECT OF IN MODE - 5" ); + END IF; + + IF IN_UNC'CONSTRAINED THEN + NULL; + ELSE + FAILED ( "'CONSTRAINED IS 'FALSE' FOR " & + "OBJECT OF IN MODE - 6" ); + END IF; + + IF INOUT_CON'CONSTRAINED THEN + NULL; + ELSE + FAILED ( "'CONSTRAINED IS 'FALSE' FOR " & + "CONSTRAINED OBJECT OF " & + "IN OUT MODE - 2" ); + END IF; + + IF OUT_CON'CONSTRAINED THEN + NULL; + ELSE + FAILED ( "'CONSTRAINED IS 'FALSE' FOR " & + "CONSTRAINED OBJECT OF " & + "OUT MODE - 2" ); + END IF; + + IF INOUT_UNC'CONSTRAINED THEN + FAILED ( "'CONSTRAINED IS 'TRUE' FOR " & + "UNCONSTRAINED OBJECT OF " & + "IN OUT MODE - 2" ); + END IF; + + IF OUT_UNC'CONSTRAINED THEN + FAILED ( "'CONSTRAINED IS 'TRUE' FOR " & + "UNCONSTRAINED OBJECT OF " & + "OUT MODE - 2" ); + END IF; + + OUT_CON := (2, ((1, 2), (3, 4))); + OUT_UNC := (2, ((1, 2), (3, 4))); + END; + END Q; + END T; + + GENERIC + CON, IN_CON : IN SQUARE; + INOUT_CON : IN OUT SQUARE; + IN_UNC : IN SQUARE; + INOUT_UNC : IN OUT SQUARE; + PACKAGE R IS END R; + + PACKAGE BODY R IS + BEGIN + IF CON'CONSTRAINED THEN + NULL; + ELSE + FAILED ( "'CONSTRAINED IS 'FALSE' FOR OBJECT " & + "OF IN MODE - 7" ); + END IF; + + IF IN_CON'CONSTRAINED THEN + NULL; + ELSE + FAILED ( "'CONSTRAINED IS 'FALSE' FOR OBJECT " & + "OF IN MODE - 8" ); + END IF; + + IF IN_UNC'CONSTRAINED THEN + NULL; + ELSE + FAILED ( "'CONSTRAINED IS 'FALSE' FOR OBJECT " & + "OF IN MODE - 9" ); + END IF; + + IF INOUT_CON'CONSTRAINED THEN + NULL; + ELSE + FAILED ( "'CONSTRAINED IS 'FALSE' FOR " & + "CONSTRAINED OBJECT OF IN OUT MODE - 3" ); + END IF; + + IF INOUT_UNC'CONSTRAINED THEN + FAILED ( "'CONSTRAINED IS 'TRUE' FOR " & + "UNCONSTRAINED OBJECT OF IN OUT MODE " & + "- 3" ); + END IF; + + END R; + + PACKAGE S IS NEW R (SC, AC, BC, AU, BU); + + BEGIN + P (SC, AC, BC, CC, AU, BU, CU); + T.Q (SC, AC, BC, CC, AU, BU, CU); + END; + + RESULT; +END C37402A; diff --git a/gcc-4.9/gcc/testsuite/ada/acats/tests/c3/c37403a.ada b/gcc-4.9/gcc/testsuite/ada/acats/tests/c3/c37403a.ada new file mode 100644 index 000000000..baa65f57b --- /dev/null +++ b/gcc-4.9/gcc/testsuite/ada/acats/tests/c3/c37403a.ada @@ -0,0 +1,186 @@ +-- C37403A.ADA + +-- Grant of Unlimited Rights +-- +-- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687, +-- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained +-- unlimited rights in the software and documentation contained herein. +-- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making +-- this public release, the Government intends to confer upon all +-- recipients unlimited rights equal to those held by the Government. +-- These rights include rights to use, duplicate, release or disclose the +-- released technical data and computer software in whole or in part, in +-- any manner and for any purpose whatsoever, and to have or permit others +-- to do so. +-- +-- DISCLAIMER +-- +-- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR +-- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED +-- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF 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 FORMAL PARAMETER OF A SUBPROGRAM, ENTRY, OR +-- GENERIC UNIT HAS AN UNCONSTRAINED TYPE WITH DISCRIMINANTS THAT DO +-- NOT HAVE DEFAULTS, 'CONSTRAINED IS 'TRUE' REGARDLESS OF THE MODE +-- OF THE PARAMETER. + +-- R.WILLIAMS 9/1/86 + +WITH REPORT; USE REPORT; +PROCEDURE C37403A IS + +BEGIN + TEST ( "C37403A", "CHECK THAT WHEN A FORMAL PARAMETER OF A " & + "SUBPROGRAM, ENTRY, OR GENERIC UNIT HAS AN " & + "UNCONSTRAINED TYPE WITH DISCRIMINANTS THAT " & + "DO NOT HAVE DEFAULTS, 'CONSTRAINED IS " & + "'TRUE' REGARDLESS OF THE MODE OF THE " & + "PARAMETER" ); + + + DECLARE + + SUBTYPE INT IS INTEGER RANGE 1.. 10; + + TYPE MATRIX IS ARRAY (INT RANGE <>, INT RANGE <>) + OF INTEGER; + + TYPE SQUARE (SIDE : INT) IS + RECORD + MAT : MATRIX (1 .. SIDE, 1 .. SIDE); + END RECORD; + + S1 : SQUARE (2) := (2, ((1, 2), (3, 4))); + + S2 : SQUARE (2) := S1; + + S3 : SQUARE (2); + + SC : CONSTANT SQUARE := (SIDE => 1, MAT => (1 => (1 => 1))); + + PROCEDURE P (PIN1, PIN2 : IN SQUARE; + PINOUT : IN OUT SQUARE; + POUT : OUT SQUARE) IS + + BEGIN + IF PIN1'CONSTRAINED THEN + NULL; + ELSE + FAILED ( "'CONSTRAINED IS 'FALSE' FOR OBJECT " & + "OF IN MODE - 1" ); + END IF; + + IF PIN2'CONSTRAINED THEN + NULL; + ELSE + FAILED ( "'CONSTRAINED IS 'FALSE' FOR OBJECT " & + "OF IN MODE - 2" ); + END IF; + + IF PINOUT'CONSTRAINED THEN + NULL; + ELSE + FAILED ( "'CONSTRAINED IS 'FALSE' FOR " & + "OBJECT OF IN OUT MODE - 1" ); + END IF; + + IF POUT'CONSTRAINED THEN + NULL; + ELSE + FAILED ( "'CONSTRAINED IS 'FALSE' FOR " & + "OBJECT OF OUT MODE - 1" ); + END IF; + + POUT := (2, ((1, 2), (3, 4))); + END P; + + TASK T IS + ENTRY Q (PIN1, PIN2 : IN SQUARE; + PINOUT : IN OUT SQUARE; + POUT : OUT SQUARE); + END T; + + TASK BODY T IS + BEGIN + ACCEPT Q (PIN1, PIN2 : IN SQUARE; + PINOUT : IN OUT SQUARE; + POUT : OUT SQUARE) DO + + BEGIN + IF PIN1'CONSTRAINED THEN + NULL; + ELSE + FAILED ( "'CONSTRAINED IS 'FALSE' FOR " & + "OBJECT OF IN MODE - 3" ); + END IF; + + IF PIN2'CONSTRAINED THEN + NULL; + ELSE + FAILED ( "'CONSTRAINED IS 'FALSE' FOR " & + "OBJECT OF IN MODE - 4" ); + END IF; + + IF PINOUT'CONSTRAINED THEN + NULL; + ELSE + FAILED ( "'CONSTRAINED IS 'FALSE' FOR " & + "OBJECT OF " & + "IN OUT MODE - 2" ); + END IF; + + IF POUT'CONSTRAINED THEN + NULL; + ELSE + FAILED ( "'CONSTRAINED IS 'FALSE' FOR " & + "OBJECT OF " & + "OUT MODE - 2" ); + END IF; + + POUT := (2, ((1, 2), (3, 4))); + END; + END Q; + END T; + + GENERIC + PIN1, PIN2 : IN SQUARE; + PINOUT : IN OUT SQUARE; + PACKAGE R IS END R; + + PACKAGE BODY R IS + BEGIN + IF PIN1'CONSTRAINED THEN + NULL; + ELSE + FAILED ( "'CONSTRAINED IS 'FALSE' FOR OBJECT " & + "OF IN MODE - 5" ); + END IF; + + IF PIN2'CONSTRAINED THEN + NULL; + ELSE + FAILED ( "'CONSTRAINED IS 'FALSE' FOR OBJECT " & + "OF IN MODE - 6" ); + END IF; + + IF PINOUT'CONSTRAINED THEN + NULL; + ELSE + FAILED ( "'CONSTRAINED IS 'FALSE' FOR " & + "OBJECT OF IN OUT MODE - 3" ); + END IF; + + END R; + + PACKAGE S IS NEW R (S1, SC, S2); + + BEGIN + P (S1, SC, S2, S3); + T.Q (S1, SC, S2, S3); + END; + + RESULT; +END C37403A; diff --git a/gcc-4.9/gcc/testsuite/ada/acats/tests/c3/c37404a.ada b/gcc-4.9/gcc/testsuite/ada/acats/tests/c3/c37404a.ada new file mode 100644 index 000000000..006d4492b --- /dev/null +++ b/gcc-4.9/gcc/testsuite/ada/acats/tests/c3/c37404a.ada @@ -0,0 +1,168 @@ +--C37404A.ADA + +-- Grant of Unlimited Rights +-- +-- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687, +-- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained +-- unlimited rights in the software and documentation contained herein. +-- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making +-- this public release, the Government intends to confer upon all +-- recipients unlimited rights equal to those held by the Government. +-- These rights include rights to use, duplicate, release or disclose the +-- released technical data and computer software in whole or in part, in +-- any manner and for any purpose whatsoever, and to have or permit others +-- to do so. +-- +-- DISCLAIMER +-- +-- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR +-- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED +-- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF 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 'CONSTRAINED IS TRUE FOR VARIABLES DECLARED WITH A +-- CONSTRAINED TYPE, FOR CONSTANT OBJECTS (EVEN IF NOT DECLARED +-- WITH A CONSTRAINED TYPE), AND DESIGNATED OBJECTS. + +-- HISTORY: +-- DHH 02/25/88 CREATED ORIGINAL TEST. + +WITH REPORT; USE REPORT; +PROCEDURE C37404A IS + + SUBTYPE INT IS INTEGER RANGE 1 .. 10; + TYPE REC(A : INT) IS + RECORD + I : INT; + END RECORD; + + TYPE ACC_REC IS ACCESS REC(4); + TYPE ACC_REC1 IS ACCESS REC; + SUBTYPE REC4 IS REC(4); + SUBTYPE REC5 IS REC; + + TYPE REC_DEF(A : INT := 5) IS + RECORD + I : INT := 1; + END RECORD; + + TYPE ACC_DEF IS ACCESS REC_DEF(4); + TYPE ACC_DEF1 IS ACCESS REC_DEF; + SUBTYPE REC6 IS REC_DEF(6); + SUBTYPE REC7 IS REC_DEF; + + A : REC4 := (A => 4, I => 1); -- CONSTRAINED. + B : REC5(4) := (A => 4, I => 1); -- CONSTRAINED. + C : REC6; -- CONSTRAINED. + D : REC7(6); -- CONSTRAINED. + E : ACC_REC1(4); -- CONSTRAINED. + F : ACC_DEF1(4); -- CONSTRAINED. + G : ACC_REC1; -- UNCONSTRAINED. + H : ACC_DEF1; -- UNCONSTRAINED. + + R : REC(5) := (A => 5, I => 1); -- CONSTRAINED. + T : REC_DEF(5); -- CONSTRAINED. + U : ACC_REC; -- CONSTRAINED. + V : ACC_DEF; -- CONSTRAINED. + W : CONSTANT REC(5) := (A => 5, I => 1); -- CONSTANT. + X : CONSTANT REC := (A => 5, I => 1); -- CONSTANT. + Y : CONSTANT REC_DEF(5) := (A => 5, I => 1); -- CONSTANT. + Z : CONSTANT REC_DEF := (A => 5, I => 1); -- CONSTANT. + +BEGIN + TEST("C37404A", "CHECK THAT 'CONSTRAINED IS TRUE FOR VARIABLES " & + "DECLARED WITH A CONSTRAINED TYPE, FOR " & + "CONSTANT OBJECTS (EVEN IF NOT DECLARED WITH A " & + "CONSTRAINED TYPE), AND DESIGNATED OBJECTS"); + + U := NEW REC(4); + V := NEW REC_DEF(4); + E := NEW REC(4); + F := NEW REC_DEF(4); + G := NEW REC(4); -- CONSTRAINED. + H := NEW REC_DEF(4); -- CONSTRAINED. + + IF NOT A'CONSTRAINED THEN + FAILED("'CONSTRAINED NOT TRUE FOR SUBTYPE1"); + END IF; + + IF NOT B'CONSTRAINED THEN + FAILED("'CONSTRAINED NOT TRUE FOR SUBTYPE2"); + END IF; + + IF NOT C'CONSTRAINED THEN + FAILED("'CONSTRAINED NOT TRUE FOR DEFAULT SUBTYPE1"); + END IF; + + IF NOT D'CONSTRAINED THEN + FAILED("'CONSTRAINED NOT TRUE FOR DEFAULT SUBTYPE2"); + END IF; + + IF NOT R'CONSTRAINED THEN + FAILED("'CONSTRAINED NOT TRUE FOR RECORD COMPONENT"); + END IF; + + IF NOT T'CONSTRAINED THEN + FAILED("'CONSTRAINED NOT TRUE FOR DEFAULT VARIABLE"); + END IF; + + IF NOT E.ALL'CONSTRAINED THEN + FAILED("'CONSTRAINED NOT TRUE FOR ACCESS 1"); + END IF; + + IF NOT F.ALL'CONSTRAINED THEN + FAILED("'CONSTRAINED NOT TRUE FOR DEFAULT ACCESS 1"); + END IF; + + IF NOT G.ALL'CONSTRAINED THEN + FAILED("'CONSTRAINED NOT TRUE FOR ACCESS 2"); + END IF; + + IF NOT H.ALL'CONSTRAINED THEN + FAILED("'CONSTRAINED NOT TRUE FOR DEFAULT ACCESS 2"); + END IF; + + IF NOT U.ALL'CONSTRAINED THEN + FAILED("'CONSTRAINED NOT TRUE FOR ACCESS 3"); + END IF; + + IF NOT V.ALL'CONSTRAINED THEN + FAILED("'CONSTRAINED NOT TRUE FOR DEFAULT ACCESS 3"); + END IF; + + IF NOT W'CONSTRAINED THEN + FAILED("'CONSTRAINED NOT TRUE FOR CONSTANT, CONSTRAINED"); + END IF; + + IF NOT X'CONSTRAINED THEN + FAILED("'CONSTRAINED NOT TRUE FOR CONSTANT, UNCONSTRAINED"); + END IF; + + IF NOT Y'CONSTRAINED THEN + FAILED("'CONSTRAINED NOT TRUE FOR DEFAULT CONSTANT, " & + "CONSTRAINED"); + END IF; + + IF NOT Z'CONSTRAINED THEN + FAILED("'CONSTRAINED NOT TRUE FOR DEFAULT CONSTANT, " & + "UNCONSTRAINED"); + END IF; + + IF IDENT_INT(T.I) /= 1 OR + IDENT_INT(C.I) /= 1 OR + IDENT_INT(D.I) /= 1 OR + IDENT_INT(W.A) /= 5 OR + IDENT_INT(X.A) /= 5 OR + IDENT_INT(Y.A) /= 5 OR + IDENT_INT(Z.I) /= 1 OR + IDENT_INT(A.I) /= 1 OR + IDENT_INT(B.I) /= 1 OR + IDENT_BOOL(R.I /= 1) THEN + FAILED("INCORRECT INITIALIZATION VALUES"); + END IF; + + RESULT; +END C37404A; diff --git a/gcc-4.9/gcc/testsuite/ada/acats/tests/c3/c37404b.ada b/gcc-4.9/gcc/testsuite/ada/acats/tests/c3/c37404b.ada new file mode 100644 index 000000000..d7a03ecd6 --- /dev/null +++ b/gcc-4.9/gcc/testsuite/ada/acats/tests/c3/c37404b.ada @@ -0,0 +1,148 @@ +--C37404B.ADA + +-- Grant of Unlimited Rights +-- +-- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687, +-- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained +-- unlimited rights in the software and documentation contained herein. +-- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making +-- this public release, the Government intends to confer upon all +-- recipients unlimited rights equal to those held by the Government. +-- These rights include rights to use, duplicate, release or disclose the +-- released technical data and computer software in whole or in part, in +-- any manner and for any purpose whatsoever, and to have or permit others +-- to do so. +-- +-- DISCLAIMER +-- +-- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR +-- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED +-- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF 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 'CONSTRAINED IS FALSE FOR VARIABLES THAT HAVE +-- DISCRIMINANTS WITH DEFAULT VALUES. + +-- HISTORY: +-- LDC 06/08/88 CREATED ORIGINAL TEST. + +WITH REPORT; USE REPORT; +PROCEDURE C37404B IS + + SUBTYPE INT IS INTEGER RANGE 1 .. 10; + + TYPE REC_DEF(A : INT := 5) IS + RECORD + I : INT := 1; + END RECORD; + + SUBTYPE REC_DEF_SUB IS REC_DEF; + + TYPE REC_DEF_ARR IS ARRAY (INTEGER RANGE -8..7) OF REC_DEF; + TYPE REC_DEF_SARR IS ARRAY (INTEGER RANGE -8..7) OF REC_DEF_SUB; + + PACKAGE PRI_PACK IS + TYPE REC_DEF_PRI(A : INTEGER := 5) IS PRIVATE; + TYPE REC_DEF_LIM_PRI(A : INTEGER := 5) IS LIMITED PRIVATE; + + PRIVATE + + TYPE REC_DEF_PRI(A : INTEGER := 5) IS + RECORD + I : INTEGER := 1; + END RECORD; + + TYPE REC_DEF_LIM_PRI(A : INTEGER := 5) IS + RECORD + I : INTEGER := 1; + END RECORD; + + END PRI_PACK; + USE PRI_PACK; + + A : REC_DEF; + B : REC_DEF_SUB; + C : ARRAY (0..15) OF REC_DEF; + D : ARRAY (0..15) OF REC_DEF_SUB; + E : REC_DEF_ARR; + F : REC_DEF_SARR; + G : REC_DEF_PRI; + H : REC_DEF_LIM_PRI; + + Z : REC_DEF; + + PROCEDURE SUBPROG(REC : OUT REC_DEF) IS + + BEGIN + IF REC'CONSTRAINED THEN + FAILED("'CONSTRAINED TRUE FOR SUBPROGRAM OUT " & + "PARAMETER INSIDE THE SUBPROGRAM"); + END IF; + END SUBPROG; + +BEGIN + TEST("C37404B", "CHECK THAT 'CONSTRAINED IS FALSE FOR VARIABLES" & + " THAT HAVE DISCRIMINANTS WITH DEFAULT VALUES."); + + IF A'CONSTRAINED THEN + FAILED("'CONSTRAINED TRUE FOR RECORD COMPONENT"); + END IF; + + IF B'CONSTRAINED THEN + FAILED("'CONSTRAINED TRUE FOR SUBTYPE"); + END IF; + + IF C(1)'CONSTRAINED THEN + FAILED("'CONSTRAINED TRUE FOR ARRAY TYPE"); + END IF; + + IF D(1)'CONSTRAINED THEN + FAILED("'CONSTRAINED TRUE FOR ARRAY OF SUBTYPE"); + END IF; + + IF E(1)'CONSTRAINED THEN + FAILED("'CONSTRAINED TRUE FOR ARRAY TYPE"); + END IF; + + IF F(1)'CONSTRAINED THEN + FAILED("'CONSTRAINED TRUE FOR ARRAY OF SUBTYPE"); + END IF; + + IF G'CONSTRAINED THEN + FAILED("'CONSTRAINED TRUE FOR PRIVATE TYPE"); + END IF; + + IF H'CONSTRAINED THEN + FAILED("'CONSTRAINED TRUE FOR LIMITED PRIVATE TYPE"); + END IF; + + SUBPROG(Z); + IF Z'CONSTRAINED THEN + FAILED("'CONSTRAINED TRUE FOR SUBPROGRAM OUT PARAMETER " & + "AFTER THE CALL"); + END IF; + + IF IDENT_INT(A.I) /= 1 OR + IDENT_INT(B.I) /= 1 OR + IDENT_INT(C(1).I) /= 1 OR + IDENT_INT(D(1).I) /= 1 OR + IDENT_INT(E(1).I) /= 1 OR + IDENT_INT(F(1).I) /= 1 OR + IDENT_INT(Z.I) /= 1 OR + IDENT_INT(A.A) /= 5 OR + IDENT_INT(B.A) /= 5 OR + IDENT_INT(C(1).A) /= 5 OR + IDENT_INT(D(1).A) /= 5 OR + IDENT_INT(E(1).A) /= 5 OR + IDENT_INT(F(1).A) /= 5 OR + IDENT_INT(G.A) /= 5 OR + IDENT_INT(H.A) /= 5 OR + IDENT_INT(Z.A) /= 5 THEN + FAILED("INCORRECT INITIALIZATION VALUES"); + END IF; + + RESULT; +END C37404B; diff --git a/gcc-4.9/gcc/testsuite/ada/acats/tests/c3/c37405a.ada b/gcc-4.9/gcc/testsuite/ada/acats/tests/c3/c37405a.ada new file mode 100644 index 000000000..187033773 --- /dev/null +++ b/gcc-4.9/gcc/testsuite/ada/acats/tests/c3/c37405a.ada @@ -0,0 +1,161 @@ +-- C37405A.ADA + +-- Grant of Unlimited Rights +-- +-- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687, +-- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained +-- unlimited rights in the software and documentation contained herein. +-- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making +-- this public release, the Government intends to confer upon all +-- recipients unlimited rights equal to those held by the Government. +-- These rights include rights to use, duplicate, release or disclose the +-- released technical data and computer software in whole or in part, in +-- any manner and for any purpose whatsoever, and to have or permit others +-- to do so. +-- +-- DISCLAIMER +-- +-- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR +-- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED +-- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF 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 ASSIGNING TO A CONSTRAINED OR UNCONSTRAINED +-- OBJECT OR FORMAL PARAMETER OF A TYPE DECLARED WITH DEFAULT +-- DISCRIMINANTS, THE ASSIGNMENT DOES NOT CHANGE THE 'CONSTRAINED +-- ATTRIBUTE VALUE ASSOCIATED WITH THE OBJECT OR PARAMETER. + +-- ASL 7/21/81 +-- TBN 1/20/86 RENAMED FROM C37209A.ADA AND REVISED THE ASSIGNMENTS +-- OF CONSTRAINED AND UNCONSTRAINED OBJECTS TO ARRAY AND +-- RECORD COMPONENTS. + +WITH REPORT; USE REPORT; +PROCEDURE C37405A IS + + TYPE REC(DISC : INTEGER := 25) IS + RECORD + COMP : INTEGER; + END RECORD; + + SUBTYPE CONSTR IS REC(10); + SUBTYPE UNCONSTR IS REC; + + TYPE REC_C IS + RECORD + COMP: CONSTR; + END RECORD; + + TYPE REC_U IS + RECORD + COMP: UNCONSTR; + END RECORD; + + C1,C2 : CONSTR; + U1,U2 : UNCONSTR; +-- C2 AND U2 ARE NOT PASSED TO EITHER PROC1 OR PROC2. + + ARR_C : ARRAY (1..5) OF CONSTR; + ARR_U : ARRAY (1..5) OF UNCONSTR; + + REC_COMP_C : REC_C; + REC_COMP_U : REC_U; + + PROCEDURE PROC11(PARM : IN OUT UNCONSTR; B : IN BOOLEAN) IS + BEGIN + PARM := C2; + IF IDENT_BOOL(B) /= PARM'CONSTRAINED THEN + FAILED ("'CONSTRAINED ATTRIBUTE CHANGED BY " & + "ASSIGNMENT - 1"); + END IF; + END PROC11; + + PROCEDURE PROC12(PARM : IN OUT UNCONSTR; B : IN BOOLEAN) IS + BEGIN + PARM := U2; + IF B /= PARM'CONSTRAINED THEN + FAILED ("'CONSTRAINED ATTRIBUTE CHANGED BY " & + "ASSIGNMENT - 2"); + END IF; + END PROC12; + + PROCEDURE PROC1(PARM : IN OUT UNCONSTR; B : IN BOOLEAN) IS + BEGIN + IF B /= PARM'CONSTRAINED THEN + FAILED ("'CONSTRAINED ATTRIBUTE CHANGED BY " & + "PASSING PARAMETER"); + END IF; + + PROC11(PARM, B); + + PROC12(PARM, B); + + END PROC1; + + PROCEDURE PROC2(PARM : IN OUT CONSTR) IS + BEGIN + COMMENT ("CALLING PROC1 FROM PROC2"); -- IN CASE TEST FAILS. + PROC1(PARM,TRUE); + PARM := U2; + IF NOT PARM'CONSTRAINED THEN + FAILED ("'CONSTRAINED ATTRIBUTE CHANGED BY " & + "ASSIGNMENT - 3"); + END IF; + END PROC2; +BEGIN + TEST("C37405A", "'CONSTRAINED ATTRIBUTE OF OBJECTS, FORMAL " & + "PARAMETERS CANNOT BE CHANGED BY ASSIGNMENT"); + + C2 := (DISC => IDENT_INT(10), COMP => 3); + U2 := (DISC => IDENT_INT(10), COMP => 4); + + ARR_C := (1..5 => U2); + ARR_U := (1..5 => C2); + + REC_COMP_C := (COMP => U2); + REC_COMP_U := (COMP => C2); + + C1 := U2; + U1 := C2; + + IF U1'CONSTRAINED OR NOT C1'CONSTRAINED THEN + FAILED ("'CONSTRAINED ATTRIBUTE CHANGED BY ASSIGNMENT - 4"); + END IF; + + IF ARR_U(3)'CONSTRAINED OR NOT ARR_C(4)'CONSTRAINED THEN + FAILED ("'CONSTRAINED ATTRIBUTE CHANGED BY ASSIGNMENT - 5"); + END IF; + + IF REC_COMP_U.COMP'CONSTRAINED + OR NOT REC_COMP_C.COMP'CONSTRAINED THEN + FAILED ("'CONSTRAINED ATTRIBUTE CHANGED BY ASSIGNMENT - 6"); + END IF; + + COMMENT("CALLING PROC1 DIRECTLY"); + PROC1(C1,TRUE); + PROC2(C1); + + COMMENT("CALLING PROC1 DIRECTLY"); + PROC1(U1,FALSE); + PROC2(U1); + + COMMENT("CALLING PROC1 DIRECTLY"); + PROC1(ARR_C(4), TRUE); + PROC2(ARR_C(5)); + + COMMENT("CALLING PROC1 DIRECTLY"); + PROC1(ARR_U(2), FALSE); + PROC2(ARR_U(3)); + + COMMENT("CALLING PROC1 DIRECTLY"); + PROC1(REC_COMP_C.COMP, TRUE); + PROC2(REC_COMP_C.COMP); + + COMMENT("CALLING PROC1 DIRECTLY"); + PROC1(REC_COMP_U.COMP, FALSE); + PROC2(REC_COMP_U.COMP); + + RESULT; +END C37405A; diff --git a/gcc-4.9/gcc/testsuite/ada/acats/tests/c3/c37411a.ada b/gcc-4.9/gcc/testsuite/ada/acats/tests/c3/c37411a.ada new file mode 100644 index 000000000..d11574b61 --- /dev/null +++ b/gcc-4.9/gcc/testsuite/ada/acats/tests/c3/c37411a.ada @@ -0,0 +1,82 @@ +-- C37411A.ADA + +-- Grant of Unlimited Rights +-- +-- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687, +-- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained +-- unlimited rights in the software and documentation contained herein. +-- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making +-- this public release, the Government intends to confer upon all +-- recipients unlimited rights equal to those held by the Government. +-- These rights include rights to use, duplicate, release or disclose the +-- released technical data and computer software in whole or in part, in +-- any manner and for any purpose whatsoever, and to have or permit others +-- to do so. +-- +-- DISCLAIMER +-- +-- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR +-- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED +-- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF 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 OPERATIONS OF ASSIGNMENT, COMPARISON, MEMBERSHIP +-- TESTS, QUALIFICATION, TYPE CONVERSION, 'BASE, 'SIZE AND 'ADDRESS, +-- ARE DEFINED FOR NULL RECORDS. + +-- HISTORY: +-- DHH 03/04/88 CREATED ORIGINAL TEST. +-- PWN 11/30/94 REMOVED 'BASE USE ILLEGAL IN ADA 9X. + +WITH SYSTEM; USE SYSTEM; +WITH REPORT; USE REPORT; +PROCEDURE C37411A IS + TYPE S IS + RECORD + NULL; + END RECORD; + + SUBTYPE SS IS S; + + U,V,W : S; + X : SS; + +BEGIN + + TEST("C37411A", "CHECK THAT THE OPERATIONS OF ASSIGNMENT, " & + "COMPARISON, MEMBERSHIP TESTS, QUALIFICATION, " & + "TYPE CONVERSION, 'BASE, 'SIZE AND 'ADDRESS, " & + "ARE DEFINED FOR NULL RECORDS"); + U := W; + IF U /= W THEN + FAILED("EQUALITY/ASSIGNMENT DOES NOT PERFORM CORRECTLY"); + END IF; + + IF V NOT IN S THEN + FAILED("MEMBERSHIP DOES NOT PERFORM CORRECTLY"); + END IF; + + IF X /= SS(V) THEN + FAILED("TYPE CONVERSION DOES NOT PERFORM CORRECTLY"); + END IF; + + IF S'(U) /= S'(W) THEN + FAILED("QUALIFIED EXPRESSION DOES NOT PERFORM CORRECTLY"); + END IF; + + IF X'SIZE /= V'SIZE THEN + FAILED("'BASE'SIZE DOES NOT PERFORM CORRECTLY WHEN PREFIX " & + "IS AN OBJECT"); + END IF; + + IF X'ADDRESS = V'ADDRESS THEN + COMMENT("NULL RECORDS HAVE THE SAME ADDRESS"); + ELSE + COMMENT("NULL RECORDS DO NOT HAVE THE SAME ADDRESS"); + END IF; + + RESULT; +END C37411A; diff --git a/gcc-4.9/gcc/testsuite/ada/acats/tests/c3/c380001.a b/gcc-4.9/gcc/testsuite/ada/acats/tests/c3/c380001.a new file mode 100644 index 000000000..0ebe4d31c --- /dev/null +++ b/gcc-4.9/gcc/testsuite/ada/acats/tests/c3/c380001.a @@ -0,0 +1,128 @@ +-- C380001.A +-- +-- Grant of Unlimited Rights +-- +-- The Ada Conformity Assessment Authority (ACAA) holds unlimited +-- rights in the software and documentation contained herein. Unlimited +-- rights are the same as those granted by the U.S. Government for older +-- parts of the Ada Conformity Assessment Test Suite, and are defined +-- in DFAR 252.227-7013(a)(19). By making this public release, the ACAA +-- intends to confer upon all recipients unlimited rights equal to those +-- held by the ACAA. These rights include rights to use, duplicate, +-- release or disclose the released technical data and computer software +-- in whole or in part, in any manner and for any purpose whatsoever, and +-- to have or permit others to do so. +-- +-- DISCLAIMER +-- +-- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR +-- DISCLOSED ARE AS IS. THE ACAA MAKES NO EXPRESS OR IMPLIED +-- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE +-- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE +-- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A +-- PARTICULAR PURPOSE OF SAID MATERIAL. +--* +-- +-- OBJECTIVE: +-- Check that checks are made properly when a per-object expression contains +-- an attribute whose prefix denotes the current instance of the type. +-- (Defect Report 8652/0002, as reflected in Technical Corrigendum 1, +-- RM95 3.8(18/1)). +-- +-- CHANGE HISTORY: +-- 9 FEB 2001 PHL Initial version. +-- 29 JUN 2002 RLB Readied for release. +-- +--! +with Ada.Exceptions; +use Ada.Exceptions; +with Report; +use Report; +procedure C380001 is + + type Negative is range Integer'First .. -1; + + type R1 is + record + C : Negative := Negative (Ident_Int (R1'Size)); + end record; + + + type R2; + + type R3 (D1 : access R2; D2 : Natural) is limited null record; + + type R2 is limited + record + C : R3 (R2'Access, Ident_Int (-1)); + end record; + +begin + Test ("C380001", "Check that checks are made properly when a " & + "per-object expression contains an attribute whose " & + "prefix denotes the current instance of the type"); + begin + declare + X : R1; + begin + Failed + ("No exception raised when evaluating a per-object expression " & + "containing an attribute - 1"); + end; + exception + when Constraint_Error => + null; + when E: others => + Failed ("Exception " & Exception_Name (E) & + " raised - " & Exception_Information (E) & " - 1"); + end; + + declare + type A is access R1; + X : A; + begin + X := new R1; + Failed ("No exception raised when evaluating a per-object expression " & + "containing an attribute - 2"); + exception + when Constraint_Error => + null; + when E: others => + Failed ("Exception " & Exception_Name (E) & + " raised - " & Exception_Information (E) & " - 2"); + end; + + begin + declare + X : R2; + begin + Failed + ("No exception raised when elaborating a per-object constraint " & + "containing an attribute - 3"); + end; + exception + when Constraint_Error => + null; + when E: others => + Failed ("Exception " & Exception_Name (E) & + " raised - " & Exception_Information (E) & " - 3"); + end; + + declare + type A is access R2; + X : A; + begin + X := new R2; + Failed + ("No exception raised when evaluating a per-object constraint " & + "containing an attribute - 4"); + exception + when Constraint_Error => + null; + when E: others => + Failed ("Exception " & Exception_Name (E) & + " raised - " & Exception_Information (E) & " - 4"); + end; + + Result; +end C380001; diff --git a/gcc-4.9/gcc/testsuite/ada/acats/tests/c3/c380002.a b/gcc-4.9/gcc/testsuite/ada/acats/tests/c3/c380002.a new file mode 100644 index 000000000..ae58676cb --- /dev/null +++ b/gcc-4.9/gcc/testsuite/ada/acats/tests/c3/c380002.a @@ -0,0 +1,72 @@ +-- C380002.A +-- +-- Grant of Unlimited Rights +-- +-- The Ada Conformity Assessment Authority (ACAA) holds unlimited +-- rights in the software and documentation contained herein. Unlimited +-- rights are the same as those granted by the U.S. Government for older +-- parts of the Ada Conformity Assessment Test Suite, and are defined +-- in DFAR 252.227-7013(a)(19). By making this public release, the ACAA +-- intends to confer upon all recipients unlimited rights equal to those +-- held by the ACAA. These rights include rights to use, duplicate, +-- release or disclose the released technical data and computer software +-- in whole or in part, in any manner and for any purpose whatsoever, and +-- to have or permit others to do so. +-- +-- DISCLAIMER +-- +-- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR +-- DISCLOSED ARE AS IS. THE ACAA MAKES NO EXPRESS OR IMPLIED +-- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE +-- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE +-- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A +-- PARTICULAR PURPOSE OF SAID MATERIAL. +--* +-- +-- OBJECTIVE: +-- Check that an expression in a per-object discriminant constraint which is +-- part of a named association is evaluated once for each association. +-- (Defect Report 8652/0002, as reflected in Technical Corrigendum 1, +-- RM95 3.8(18.1/1)). +-- +-- CHANGE HISTORY: +-- 9 FEB 2001 PHL Initial version. +-- 29 JUN 2002 RLB Readied for release. +-- +--! +with Ada.Exceptions; +use Ada.Exceptions; +with Report; +use Report; +procedure C380002 is + + F_Val : Integer := Ident_Int (0); + + function F return Integer is + begin + F_Val := F_Val + Ident_Int (1); + return F_Val; + end F; + + type R1; + + type R2 (D0 : Integer; D1 : access R1; D2 : Integer; D3 : Integer) is + limited null record; + + type R1 is limited + record + C : R2 (D1 => R1'Access, D0 | D2 | D3 => F); + end record; + +begin + Test ("C380002", "Check that an expression in a per-object discriminant " & + "constraint which is part of a named association is " & + "evaluated once for each association"); + + if not Equal (F_Val, 3) then + Failed ("Expression not evaluated the proper number of times"); + end if; + + Result; +end C380002; + diff --git a/gcc-4.9/gcc/testsuite/ada/acats/tests/c3/c380003.a b/gcc-4.9/gcc/testsuite/ada/acats/tests/c3/c380003.a new file mode 100644 index 000000000..451d17703 --- /dev/null +++ b/gcc-4.9/gcc/testsuite/ada/acats/tests/c3/c380003.a @@ -0,0 +1,223 @@ +-- C380003.A +-- +-- Grant of Unlimited Rights +-- +-- The Ada Conformity Assessment Authority (ACAA) holds unlimited +-- rights in the software and documentation contained herein. Unlimited +-- rights are the same as those granted by the U.S. Government for older +-- parts of the Ada Conformity Assessment Test Suite, and are defined +-- in DFAR 252.227-7013(a)(19). By making this public release, the ACAA +-- intends to confer upon all recipients unlimited rights equal to those +-- held by the ACAA. These rights include rights to use, duplicate, +-- release or disclose the released technical data and computer software +-- in whole or in part, in any manner and for any purpose whatsoever, and +-- to have or permit others to do so. +-- +-- DISCLAIMER +-- +-- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR +-- DISCLOSED ARE AS IS. THE ACAA MAKES NO EXPRESS OR IMPLIED +-- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE +-- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE +-- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A +-- PARTICULAR PURPOSE OF SAID MATERIAL. +--* +-- +-- OBJECTIVE: +-- Check that per-object expressions are evaluated as specified for +-- protected components. (Defect Report 8652/0002, as reflected in +-- Technical Corrigendum 1, RM95 3.6(22/1) and 3.8(18/1)). +-- +-- CHANGE HISTORY: +-- 9 FEB 2001 PHL Initial version. +-- 29 JUN 2002 RLB Readied for release. +-- +--! +with Report; +use Report; +procedure C380003 is + + subtype Sm is Integer range 1 .. 10; + + type Rec (D1, D2 : Sm) is + record + null; + end record; + +begin + Test ("C380003", + "Check compatibility of discriminant expressions" & + " when the constraint depends on discriminants, " & + "and the discriminants have defaults - protected components"); + + declare + protected type Cons (D3 : Integer := Ident_Int (11)) is + function C1_D1 return Integer; + function C1_D2 return Integer; + private + C1 : Rec (D3, 1); + end Cons; + protected body Cons is + function C1_D1 return Integer is + begin + return C1.D1; + end C1_D1; + function C1_D2 return Integer is + begin + return C1.D2; + end C1_D2; + end Cons; + + function Is_Ok + (C : Cons; D3 : Integer; C1_D1 : Integer; C1_D2 : Integer) + return Boolean is + begin + return C.D3 = D3 and C.C1_D1 = C1_D1 and C.C1_D2 = C1_D2; + end Is_Ok; + + begin + begin + declare + X : Cons; + begin + Failed ("Discriminant check not performed - 1"); + if not Is_Ok (X, 1, 1, 1) then + Comment ("Shouldn't get here"); + end if; + end; + exception + when Constraint_Error => + null; + when others => + Failed ("Unexpected exception - 1"); + end; + + begin + declare + type Acc_Cons is access Cons; + X : Acc_Cons; + begin + X := new Cons; + Failed ("Discriminant check not performed - 2"); + begin + if not Is_Ok (X.all, 1, 1, 1) then + Comment ("Irrelevant"); + end if; + end; + exception + when Constraint_Error => + null; + when others => + Failed ("Unexpected exception raised - 2"); + end; + exception + when others => + Failed ("Constraint checked too soon - 2"); + end; + + begin + declare + subtype Scons is Cons; + begin + declare + X : Scons; + begin + Failed ("Discriminant check not performed - 3"); + if not Is_Ok (X, 1, 1, 1) then + Comment ("Irrelevant"); + end if; + end; + exception + when Constraint_Error => + null; + when others => + Failed ("Unexpected exception raised - 3"); + end; + exception + when others => + Failed ("Constraint checked too soon - 3"); + end; + + begin + declare + type Arr is array (1 .. 5) of Cons; + begin + declare + X : Arr; + begin + Failed ("Discriminant check not performed - 4"); + for I in Arr'Range loop + if not Is_Ok (X (I), 1, 1, 1) then + Comment ("Irrelevant"); + end if; + end loop; + end; + exception + when Constraint_Error => + null; + when others => + Failed ("Unexpected exception raised - 4"); + end; + exception + when others => + Failed ("Constraint checked too soon - 4"); + end; + + begin + declare + type Nrec is + record + C1 : Cons; + end record; + begin + declare + X : Nrec; + begin + Failed ("Discriminant check not performed - 5"); + if not Is_Ok (X.C1, 1, 1, 1) then + Comment ("Irrelevant"); + end if; + end; + exception + when Constraint_Error => + null; + when others => + Failed ("Unexpected exception raised - 5"); + end; + exception + when others => + Failed ("Constraint checked too soon - 5"); + end; + + begin + declare + type Drec is new Cons; + begin + declare + X : Drec; + begin + Failed ("Discriminant check not performed - 6"); + if not Is_Ok (Cons (X), 1, 1, 1) then + Comment ("Irrelevant"); + end if; + end; + exception + when Constraint_Error => + null; + when others => + Failed ("Unexpected exception raised - 6"); + end; + exception + when others => + Failed ("Constraint checked too soon - 6"); + end; + + end; + + Result; + +exception + when others => + Failed ("Constraint check done too early"); + Result; +end C380003; diff --git a/gcc-4.9/gcc/testsuite/ada/acats/tests/c3/c380004.a b/gcc-4.9/gcc/testsuite/ada/acats/tests/c3/c380004.a new file mode 100644 index 000000000..f83728b5f --- /dev/null +++ b/gcc-4.9/gcc/testsuite/ada/acats/tests/c3/c380004.a @@ -0,0 +1,385 @@ +-- C380004.A +-- +-- Grant of Unlimited Rights +-- +-- The Ada Conformity Assessment Authority (ACAA) holds unlimited +-- rights in the software and documentation contained herein. Unlimited +-- rights are the same as those granted by the U.S. Government for older +-- parts of the Ada Conformity Assessment Test Suite, and are defined +-- in DFAR 252.227-7013(a)(19). By making this public release, the ACAA +-- intends to confer upon all recipients unlimited rights equal to those +-- held by the ACAA. These rights include rights to use, duplicate, +-- release or disclose the released technical data and computer software +-- in whole or in part, in any manner and for any purpose whatsoever, and +-- to have or permit others to do so. +-- +-- DISCLAIMER +-- +-- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR +-- DISCLOSED ARE AS IS. THE ACAA MAKES NO EXPRESS OR IMPLIED +-- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE +-- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE +-- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A +-- PARTICULAR PURPOSE OF SAID MATERIAL. +--* +-- +-- OBJECTIVE: +-- Check that per-object expressions are evaluated as specified for entry +-- families and protected components. (Defect Report 8652/0002, +-- as reflected in Technical Corrigendum 1, RM95 3.6(22/1), 3.8(18/1), and +-- 9.5.2(22/1)). +-- +-- CHANGE HISTORY: +-- 9 FEB 2001 PHL Initial version. +-- 29 JUN 2002 RLB Readied for release. +-- +--! +with Report; +use Report; +procedure C380004 is + + type Rec (D1, D2 : Positive) is + record + null; + end record; + + F1_Poe : Integer; + + function Chk (Poe : Integer; Value : Integer; Message : String) + return Boolean is + begin + if Poe /= Value then + Failed (Message & ": Poe is " & Integer'Image (Poe)); + end if; + return True; + end Chk; + + function F1 return Integer is + begin + F1_Poe := F1_Poe - Ident_Int (1); + return F1_Poe; + end F1; + + generic + type T is limited private; + with function Is_Ok (X : T; + Param1 : Integer; + Param2 : Integer; + Param3 : Integer) return Boolean; + procedure Check; + + procedure Check is + begin + + declare + type Poe is new T; + Chk1 : Boolean := Chk (F1_Poe, 17, "F1 evaluated"); + X : Poe; -- F1 evaluated + Y : Poe; -- F1 evaluated + Chk2 : Boolean := Chk (F1_Poe, 15, "F1 not evaluated"); + begin + if not Is_Ok (T (X), 16, 16, 17) or + not Is_Ok (T (Y), 15, 15, 17) then + Failed ("Discriminant values not correct - 0"); + end if; + end; + + declare + type Poe is new T; + begin + begin + declare + X : Poe; + begin + if not Is_Ok (T (X), 14, 14, 17) then + Failed ("Discriminant values not correct - 1"); + end if; + end; + exception + when others => + Failed ("Unexpected exception - 1"); + end; + + declare + type Acc_Poe is access Poe; + X : Acc_Poe; + begin + X := new Poe; + begin + if not Is_Ok (T (X.all), 13, 13, 17) then + Failed ("Discriminant values not correct - 2"); + end if; + end; + exception + when others => + Failed ("Unexpected exception raised - 2"); + end; + + declare + subtype Spoe is Poe; + X : Spoe; + begin + if not Is_Ok (T (X), 12, 12, 17) then + Failed ("Discriminant values not correct - 3"); + end if; + exception + when others => + Failed ("Unexpected exception raised - 3"); + end; + + declare + type Arr is array (1 .. 2) of Poe; + X : Arr; + begin + if Is_Ok (T (X (1)), 11, 11, 17) and then + Is_Ok (T (X (2)), 10, 10, 17) then + null; + elsif Is_Ok (T (X (2)), 11, 11, 17) and then + Is_Ok (T (X (1)), 10, 10, 17) then + null; + else + Failed ("Discriminant values not correct - 4"); + end if; + exception + when others => + Failed ("Unexpected exception raised - 4"); + end; + + declare + type Nrec is + record + C1, C2 : Poe; + end record; + X : Nrec; + begin + if Is_Ok (T (X.C1), 8, 8, 17) and then + Is_Ok (T (X.C2), 9, 9, 17) then + null; + elsif Is_Ok (T (X.C2), 8, 8, 17) and then + Is_Ok (T (X.C1), 9, 9, 17) then + null; + else + Failed ("Discriminant values not correct - 5"); + end if; + exception + when others => + Failed ("Unexpected exception raised - 5"); + end; + + declare + type Drec is new Poe; + X : Drec; + begin + if not Is_Ok (T (X), 7, 7, 17) then + Failed ("Discriminant values not correct - 6"); + end if; + exception + when others => + Failed ("Unexpected exception raised - 6"); + end; + end; + end Check; + + +begin + Test ("C380004", + "Check evaluation of discriminant expressions " & + "when the constraint depends on a discriminant, " & + "and the discriminants have defaults - discriminant-dependent" & + "entry families and protected components"); + + + Comment ("Discriminant-dependent entry families for task types"); + + F1_Poe := 18; + + declare + task type Poe (D3 : Positive := F1) is + entry E (D3 .. F1); -- F1 evaluated + entry Is_Ok (D3 : Integer; + E_First : Integer; + E_Last : Integer; + Ok : out Boolean); + end Poe; + task body Poe is + begin + loop + select + accept Is_Ok (D3 : Integer; + E_First : Integer; + E_Last : Integer; + Ok : out Boolean) do + declare + Cnt : Natural; + begin + if Poe.D3 = D3 then + -- Can't think of a better way to check the + -- bounds of the entry family. + begin + Cnt := E (E_First)'Count; + Cnt := E (E_Last)'Count; + exception + when Constraint_Error => + Ok := False; + return; + end; + begin + Cnt := E (E_First - 1)'Count; + Ok := False; + return; + exception + when Constraint_Error => + null; + when others => + Ok := False; + return; + end; + begin + Cnt := E (E_Last + 1)'Count; + Ok := False; + return; + exception + when Constraint_Error => + null; + when others => + Ok := False; + return; + end; + Ok := True; + else + Ok := False; + return; + end if; + end; + end Is_Ok; + or + terminate; + end select; + end loop; + end Poe; + + function Is_Ok + (C : Poe; D3 : Integer; E_First : Integer; E_Last : Integer) + return Boolean is + Ok : Boolean; + begin + C.Is_Ok (D3, E_First, E_Last, Ok); + return Ok; + end Is_Ok; + + procedure Chk is new Check (Poe, Is_Ok); + + begin + Chk; + end; + + + Comment ("Discriminant-dependent entry families for protected types"); + + F1_Poe := 18; + + declare + protected type Poe (D3 : Integer := F1) is + entry E (D3 .. F1); -- F1 evaluated + function Is_Ok (D3 : Integer; E_First : Integer; E_Last : Integer) + return Boolean; + end Poe; + protected body Poe is + entry E (for I in D3 .. F1) when True is + begin + null; + end E; + function Is_Ok (D3 : Integer; E_First : Integer; E_Last : Integer) + return Boolean is + Cnt : Natural; + begin + if Poe.D3 = D3 then + -- Can't think of a better way to check the + -- bounds of the entry family. + begin + Cnt := E (E_First)'Count; + Cnt := E (E_Last)'Count; + exception + when Constraint_Error => + return False; + end; + begin + Cnt := E (E_First - 1)'Count; + return False; + exception + when Constraint_Error => + null; + when others => + return False; + end; + begin + Cnt := E (E_Last + 1)'Count; + return False; + exception + when Constraint_Error => + null; + when others => + return False; + end; + return True; + else + return False; + end if; + end Is_Ok; + end Poe; + + function Is_Ok + (C : Poe; D3 : Integer; E_First : Integer; E_Last : Integer) + return Boolean is + begin + return C.Is_Ok (D3, E_First, E_Last); + end Is_Ok; + + procedure Chk is new Check (Poe, Is_Ok); + + begin + Chk; + end; + + Comment ("Protected components"); + + F1_Poe := 18; + + declare + protected type Poe (D3 : Integer := F1) is + function C1_D1 return Integer; + function C1_D2 return Integer; + private + C1 : Rec (D3, F1); -- F1 evaluated + end Poe; + protected body Poe is + function C1_D1 return Integer is + begin + return C1.D1; + end C1_D1; + function C1_D2 return Integer is + begin + return C1.D2; + end C1_D2; + end Poe; + + function Is_Ok (C : Poe; D3 : Integer; C1_D1 : Integer; C1_D2 : Integer) + return Boolean is + begin + return C.D3 = D3 and C.C1_D1 = C1_D1 and C.C1_D2 = C1_D2; + end Is_Ok; + + procedure Chk is new Check (Poe, Is_Ok); + + begin + Chk; + end; + + Result; + +exception + when others => + Failed ("Unexpected exception"); + Result; + +end C380004; diff --git a/gcc-4.9/gcc/testsuite/ada/acats/tests/c3/c38002a.ada b/gcc-4.9/gcc/testsuite/ada/acats/tests/c3/c38002a.ada new file mode 100644 index 000000000..33d6eba8a --- /dev/null +++ b/gcc-4.9/gcc/testsuite/ada/acats/tests/c3/c38002a.ada @@ -0,0 +1,420 @@ +-- C38002A.ADA + +-- Grant of Unlimited Rights +-- +-- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687, +-- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained +-- unlimited rights in the software and documentation contained herein. +-- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making +-- this public release, the Government intends to confer upon all +-- recipients unlimited rights equal to those held by the Government. +-- These rights include rights to use, duplicate, release or disclose the +-- released technical data and computer software in whole or in part, in +-- any manner and for any purpose whatsoever, and to have or permit others +-- to do so. +-- +-- DISCLAIMER +-- +-- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR +-- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED +-- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE +-- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE +-- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A +-- PARTICULAR PURPOSE OF SAID MATERIAL. +--* +-- OBJECTIVE: +-- CHECK THAT AN UNCONSTRAINED ARRAY TYPE OR A RECORD WITHOUT +-- DEFAULT DISCRIMINANTS CAN BE USED IN AN ACCESS_TYPE_DEFINITION +-- WITHOUT AN INDEX OR DISCRIMINANT CONSTRAINT. +-- +-- CHECK THAT (NON-STATIC) INDEX OR DISCRIMINANT CONSTRAINTS CAN +-- SUBSEQUENTLY BE IMPOSED WHEN THE TYPE IS USED IN AN OBJECT +-- DECLARATION, ARRAY COMPONENT DECLARATION, RECORD COMPONENT +-- DECLARATION, ACCESS TYPE DECLARATION, PARAMETER DECLARATION, +-- DERIVED TYPE DEFINITION, PRIVATE TYPE. +-- +-- CHECK FOR UNCONSTRAINED GENERIC FORMAL TYPE. + +-- HISTORY: +-- AH 09/02/86 CREATED ORIGINAL TEST. +-- DHH 08/16/88 REVISED HEADER AND ENTERED COMMENTS FOR PRIVATE TYPE +-- AND CORRECTED INDENTATION. +-- BCB 04/12/90 ADDED CHECKS FOR AN ARRAY AS A SUBPROGRAM RETURN +-- TYPE AND AN ARRAY AS A FORMAL PARAMETER. +-- LDC 10/01/90 ADDED CODE SO F, FPROC, G, GPROC AREN'T OPTIMIZED +-- AWAY + +WITH REPORT; USE REPORT; +PROCEDURE C38002A IS + +BEGIN + TEST ("C38002A", "NON-STATIC CONSTRAINTS CAN BE IMPOSED " & + "ON ACCESS TYPES ACCESSING PREVIOUSLY UNCONSTRAINED " & + "ARRAY OR RECORD TYPES"); + + DECLARE + C3 : CONSTANT INTEGER := IDENT_INT(3); + + TYPE ARR IS ARRAY (INTEGER RANGE <>) OF INTEGER; + TYPE ARR_NAME IS ACCESS ARR; + SUBTYPE ARR_NAME_3 IS ARR_NAME(1..3); + + TYPE REC(DISC : INTEGER) IS + RECORD + COMP : ARR_NAME(1..DISC); + END RECORD; + TYPE REC_NAME IS ACCESS REC; + + OBJ : REC_NAME(C3); + + TYPE ARR2 IS ARRAY (1..10) OF REC_NAME(C3); + + TYPE REC2 IS + RECORD + COMP2 : REC_NAME(C3); + END RECORD; + + TYPE NAME_REC_NAME IS ACCESS REC_NAME(C3); + + TYPE DERIV IS NEW REC_NAME(C3); + SUBTYPE REC_NAME_3 IS REC_NAME(C3); + + FUNCTION F (PARM : REC_NAME_3) RETURN REC_NAME_3 IS + BEGIN + IF NOT EQUAL(IDENT_INT(3), 1 + IDENT_INT(2)) THEN + COMMENT("DON'T OPTIMIZE F AWAY"); + END IF; + RETURN PARM; + END; + + PROCEDURE FPROC (PARM : REC_NAME_3) IS + BEGIN + IF NOT EQUAL(IDENT_INT(4), 2 + IDENT_INT(2)) THEN + COMMENT("DON'T OPTIMIZE FPROC AWAY"); + END IF; + END FPROC; + + FUNCTION G (PA : ARR_NAME_3) RETURN ARR_NAME_3 IS + BEGIN + IF NOT EQUAL(IDENT_INT(5), 3 + IDENT_INT(2)) THEN + COMMENT("DON'T OPTIMIZE G AWAY"); + END IF; + RETURN PA; + END G; + + PROCEDURE GPROC (PA : ARR_NAME_3) IS + BEGIN + IF NOT EQUAL(IDENT_INT(6), 4 + IDENT_INT(2)) THEN + COMMENT("DON'T OPTIMIZE GPROC AWAY"); + END IF; + END GPROC; + + BEGIN + DECLARE + R : REC_NAME; + BEGIN + R := NEW REC'(DISC => 3, COMP => NEW ARR'(1..3 => 5)); + R := F(R); + R := NEW REC'(DISC => 4, COMP => NEW ARR'(1..4 => 5)); + R := F(R); + FAILED ("INCOMPATIBLE CONSTRAINT ON ACCESS VALUE " & + "ACCEPTED BY FUNCTION FOR RECORD"); + EXCEPTION + WHEN CONSTRAINT_ERROR => + IF R = NULL OR ELSE R.DISC /= 4 THEN + FAILED ("ERROR IN EVALUATION/ASSIGNMENT OF " & + "ACCESS VALUE - RECORD,FUNCTION"); + END IF; + END; + + DECLARE + R : REC_NAME; + BEGIN + R := NEW REC'(DISC => 3, COMP => NEW ARR'(1..3 => 5)); + FPROC(R); + R := NEW REC'(DISC => 4, COMP => NEW ARR'(1..4 => 5)); + FPROC(R); + FAILED ("INCOMPATIBLE CONSTRAINT ON ACCESS VALUE " & + "ACCEPTED BY PROCEDURE FOR RECORD"); + EXCEPTION + WHEN CONSTRAINT_ERROR => + IF R = NULL OR ELSE R.DISC /= 4 THEN + FAILED ("ERROR IN EVALUATION/ASSIGNMENT OF " & + "ACCESS VALUE - RECORD,PROCEDURE"); + END IF; + END; + + DECLARE + A : ARR_NAME; + BEGIN + A := NEW ARR'(1..3 => 5); + A := G(A); + A := NEW ARR'(1..4 => 6); + A := G(A); + FAILED ("INCOMPATIBLE CONSTRAINT ON ACCESS VALUE " & + "ACCEPTED BY FUNCTION FOR ARRAY"); + EXCEPTION + WHEN CONSTRAINT_ERROR => + IF A = NULL OR ELSE A(4) /= 6 THEN + FAILED ("ERROR IN EVALUATION/ASSIGNMENT OF " & + "ACCESS VALUE - ARRAY,FUNCTION"); + END IF; + END; + + DECLARE + A : ARR_NAME; + BEGIN + A := NEW ARR'(1..3 => 5); + GPROC(A); + A := NEW ARR'(1..4 => 6); + GPROC(A); + FAILED ("INCOMPATIBLE CONSTRAINT ON ACCESS VALUE " & + "ACCEPTED BY PROCEDURE FOR ARRAY"); + EXCEPTION + WHEN CONSTRAINT_ERROR => + IF A = NULL OR ELSE A(4) /= 6 THEN + FAILED ("ERROR IN EVALUATION/ASSIGNMENT OF " & + "ACCESS VALUE - ARRAY,PROCEDURE"); + END IF; + END; + END; + + DECLARE + C3 : CONSTANT INTEGER := IDENT_INT(3); + + TYPE REC (DISC : INTEGER) IS + RECORD + NULL; + END RECORD; + + TYPE P_ARR IS ARRAY (INTEGER RANGE <>) OF INTEGER; + TYPE P_ARR_NAME IS ACCESS P_ARR; + + TYPE P_REC_NAME IS ACCESS REC; + + GENERIC + TYPE UNCON_ARR IS ARRAY (INTEGER RANGE <>) OF INTEGER; + PACKAGE P IS + TYPE ACC_REC IS ACCESS REC; + TYPE ACC_ARR IS ACCESS UNCON_ARR; + TYPE ACC_P_ARR IS ACCESS P_ARR; + SUBTYPE ACC_P_ARR_3 IS ACC_P_ARR(1..3); + OBJ : ACC_REC(C3); + + TYPE ARR2 IS ARRAY (1..10) OF ACC_REC(C3); + + TYPE REC1 IS + RECORD + COMP1 : ACC_REC(C3); + END RECORD; + + TYPE REC2 IS + RECORD + COMP2 : ACC_ARR(1..C3); + END RECORD; + + SUBTYPE ACC_REC_3 IS ACC_REC(C3); + + FUNCTION F (PARM : ACC_REC_3) RETURN ACC_REC_3; + + PROCEDURE FPROC (PARM : ACC_REC_3); + + FUNCTION G (PA : ACC_P_ARR_3) RETURN ACC_P_ARR_3; + + PROCEDURE GPROC (PA : ACC_P_ARR_3); + + TYPE ACC1 IS PRIVATE; + TYPE ACC2 IS PRIVATE; + TYPE DER1 IS PRIVATE; + TYPE DER2 IS PRIVATE; + + PRIVATE + + TYPE ACC1 IS ACCESS ACC_REC(C3); + TYPE ACC2 IS ACCESS ACC_ARR(1..C3); + TYPE DER1 IS NEW ACC_REC(C3); + TYPE DER2 IS NEW ACC_ARR(1..C3); + END P; + + PACKAGE BODY P IS + FUNCTION F (PARM : ACC_REC_3) RETURN ACC_REC_3 IS + BEGIN + IF NOT EQUAL(IDENT_INT(3), 1 + IDENT_INT(2)) THEN + COMMENT("DON'T OPTIMIZE F AWAY"); + END IF; + RETURN PARM; + END; + + PROCEDURE FPROC (PARM : ACC_REC_3) IS + BEGIN + IF NOT EQUAL(IDENT_INT(4), 2 + IDENT_INT(2)) THEN + COMMENT("DON'T OPTIMIZE FPROC AWAY"); + END IF; + END FPROC; + + FUNCTION G (PA : ACC_P_ARR_3) RETURN ACC_P_ARR_3 IS + BEGIN + IF NOT EQUAL(IDENT_INT(5), 3 + IDENT_INT(2)) THEN + COMMENT("DON'T OPTIMIZE G AWAY"); + END IF; + RETURN PA; + END; + + PROCEDURE GPROC (PA : ACC_P_ARR_3) IS + BEGIN + IF NOT EQUAL(IDENT_INT(6), 4 + IDENT_INT(2)) THEN + COMMENT("DON'T OPTIMIZE GPROC AWAY"); + END IF; + END GPROC; + END P; + + PACKAGE NP IS NEW P (UNCON_ARR => P_ARR); + + USE NP; + + BEGIN + DECLARE + R : ACC_REC; + BEGIN + R := NEW REC(DISC => 3); + R := F(R); + R := NEW REC(DISC => 4); + R := F(R); + FAILED ("INCOMPATIBLE CONSTRAINT ON ACCESS VALUE " & + "ACCEPTED BY FUNCTION FOR A RECORD -GENERIC"); + EXCEPTION + WHEN CONSTRAINT_ERROR => + IF R = NULL OR ELSE R.DISC /= 4 THEN + FAILED ("ERROR IN EVALUATION/ASSIGNMENT " & + "OF ACCESS VALUE - RECORD," & + "FUNCTION -GENERIC"); + END IF; + END; + + DECLARE + R : ACC_REC; + BEGIN + R := NEW REC(DISC => 3); + FPROC(R); + R := NEW REC(DISC => 4); + FPROC(R); + FAILED ("INCOMPATIBLE CONSTRAINT ON ACCESS VALUE " & + "ACCEPTED BY PROCEDURE FOR A RECORD -GENERIC"); + EXCEPTION + WHEN CONSTRAINT_ERROR => + IF R = NULL OR ELSE R.DISC /= 4 THEN + FAILED ("ERROR IN EVALUATION/ASSIGNMENT " & + "OF ACCESS VALUE - RECORD," & + "PROCEDURE -GENERIC"); + END IF; + END; + + DECLARE + A : ACC_P_ARR; + BEGIN + A := NEW P_ARR'(1..3 => 5); + A := G(A); + A := NEW P_ARR'(1..4 => 6); + A := G(A); + FAILED ("INCOMPATIBLE CONSTRAINT ON ACCESS VALUE " & + "ACCEPTED BY FUNCTION FOR AN ARRAY -GENERIC"); + EXCEPTION + WHEN CONSTRAINT_ERROR => + IF A = NULL OR ELSE A(4) /= 6 THEN + FAILED ("ERROR IN EVALUATION/ASSIGNMENT " & + "OF ACCESS VALUE - ARRAY," & + "FUNCTION -GENERIC"); + END IF; + END; + + DECLARE + A : ACC_P_ARR; + BEGIN + A := NEW P_ARR'(1..3 => 5); + GPROC(A); + A := NEW P_ARR'(1..4 => 6); + GPROC(A); + FAILED ("INCOMPATIBLE CONSTRAINT ON ACCESS VALUE " & + "ACCEPTED BY PROCEDURE FOR AN ARRAY -GENERIC"); + EXCEPTION + WHEN CONSTRAINT_ERROR => + IF A = NULL OR ELSE A(4) /= 6 THEN + FAILED ("ERROR IN EVALUATION/ASSIGNMENT " & + "OF ACCESS VALUE - ARRAY," & + "PROCEDURE -GENERIC"); + END IF; + END; + END; + + DECLARE + TYPE CON_INT IS RANGE 1..10; + + GENERIC + TYPE UNCON_INT IS RANGE <>; + PACKAGE P2 IS + SUBTYPE NEW_INT IS UNCON_INT RANGE 1..5; + FUNCTION FUNC_INT (PARM : NEW_INT) RETURN NEW_INT; + + PROCEDURE PROC_INT (PARM : NEW_INT); + END P2; + + PACKAGE BODY P2 IS + FUNCTION FUNC_INT (PARM : NEW_INT) RETURN NEW_INT IS + BEGIN + IF NOT EQUAL(IDENT_INT(3), 1 + IDENT_INT(2)) THEN + COMMENT("DON'T OPTIMIZE F AWAY"); + END IF; + RETURN PARM; + END FUNC_INT; + + PROCEDURE PROC_INT (PARM : NEW_INT) IS + BEGIN + IF NOT EQUAL(IDENT_INT(4), 2 + IDENT_INT(2)) THEN + COMMENT("DON'T OPTIMIZE FPROC AWAY"); + END IF; + END PROC_INT; + END P2; + + PACKAGE NP2 IS NEW P2 (UNCON_INT => CON_INT); + + USE NP2; + + BEGIN + DECLARE + R : CON_INT; + BEGIN + R := 2; + R := FUNC_INT(R); + R := 8; + R := FUNC_INT(R); + FAILED ("INCOMPATIBLE CONSTRAINT ON VALUE " & + "ACCEPTED BY FUNCTION -GENERIC"); + EXCEPTION + WHEN CONSTRAINT_ERROR => + IF R /= 8 THEN + FAILED ("ERROR IN EVALUATION/ASSIGNMENT " & + "OF VALUE -FUNCTION, GENERIC"); + END IF; + END; + + DECLARE + R : CON_INT; + BEGIN + R := 2; + PROC_INT(R); + R := 9; + PROC_INT(R); + FAILED ("INCOMPATIBLE CONSTRAINT ON ACCESS VALUE " & + "ACCEPTED BY PROCEDURE -GENERIC"); + EXCEPTION + WHEN CONSTRAINT_ERROR => + IF R /= 9 THEN + FAILED ("ERROR IN EVALUATION/ASSIGNMENT " & + "OF ACCESS VALUE - PROCEDURE, " & + "GENERIC"); + END IF; + END; + END; + + RESULT; +END C38002A; diff --git a/gcc-4.9/gcc/testsuite/ada/acats/tests/c3/c38002b.ada b/gcc-4.9/gcc/testsuite/ada/acats/tests/c3/c38002b.ada new file mode 100644 index 000000000..9a51c9b8a --- /dev/null +++ b/gcc-4.9/gcc/testsuite/ada/acats/tests/c3/c38002b.ada @@ -0,0 +1,123 @@ +-- C38002B.ADA + +-- Grant of Unlimited Rights +-- +-- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687, +-- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained +-- unlimited rights in the software and documentation contained herein. +-- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making +-- this public release, the Government intends to confer upon all +-- recipients unlimited rights equal to those held by the Government. +-- These rights include rights to use, duplicate, release or disclose the +-- released technical data and computer software in whole or in part, in +-- any manner and for any purpose whatsoever, and to have or permit others +-- to do so. +-- +-- DISCLAIMER +-- +-- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR +-- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED +-- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE +-- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE +-- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A +-- PARTICULAR PURPOSE OF SAID MATERIAL. +--* +-- OBJECTIVE: +-- CHECK THAT AN UNCONSTRAINED ARRAY TYPE OR A RECORD WITHOUT +-- DEFAULT DISCRIMINANTS CAN BE USED IN AN ACCESS_TYPE_DEFINITION +-- WITHOUT AN INDEX OR DISCRIMINANT CONSTRAINT. +-- +-- CHECK THAT (NON-STATIC) INDEX OR DISCRIMINANT CONSTRAINTS CAN +-- SUBSEQUENTLY BE IMPOSED WHEN THE TYPE IS USED IN AN OBJECT +-- DECLARATION, ARRAY COMPONENT DECLARATION, RECORD COMPONENT +-- DECLARATION, ACCESS TYPE DECLARATION, PARAMETER DECLARATION, +-- ALLOCATOR, DERIVED TYPE DEFINITION, PRIVATE TYPE, OR AS THE +-- RETURN TYPE IN A FUNCTION DECLARATION. +-- +-- CHECK FOR GENERIC FORMAL ACCESS TYPES. + +-- HISTORY: +-- AH 09/02/86 CREATED ORIGINAL TEST. +-- DHH 08/22/88 REVISED HEADER, ADDED 'PRIVATE TYPE' TO COMMENTS +-- AND CORRECTED INDENTATION. + +WITH REPORT; USE REPORT; +PROCEDURE C38002B IS + + C3 : CONSTANT INTEGER := IDENT_INT(3); + + TYPE UNCON_ARR IS ARRAY (INTEGER RANGE <>) OF INTEGER; + TYPE REC (DISC : INTEGER) IS + RECORD + NULL; + END RECORD; + + TYPE P_ARR_NAME IS ACCESS UNCON_ARR; + TYPE P_REC_NAME IS ACCESS REC; + + GENERIC + TYPE ACC_REC IS ACCESS REC; + TYPE ACC_ARR IS ACCESS UNCON_ARR; + PACKAGE P IS + OBJ : ACC_REC(C3); + + TYPE ARR2 IS ARRAY (1..10) OF ACC_REC(C3); + + TYPE REC1 IS + RECORD + COMP1 : ACC_REC(C3); + END RECORD; + + TYPE REC2 IS + RECORD + COMP2 : ACC_ARR(1..C3); + END RECORD; + + SUBTYPE ACC_REC_3 IS ACC_REC(C3); + R : ACC_REC; + + FUNCTION F (PARM : ACC_REC_3) RETURN ACC_REC_3; + + TYPE ACC1 IS PRIVATE; + TYPE ACC2 IS PRIVATE; + TYPE DER1 IS PRIVATE; + TYPE DER2 IS PRIVATE; + + PRIVATE + + TYPE ACC1 IS ACCESS ACC_REC(C3); + TYPE ACC2 IS ACCESS ACC_ARR(1..C3); + TYPE DER1 IS NEW ACC_REC(C3); + TYPE DER2 IS NEW ACC_ARR(1..C3); + END P; + + PACKAGE BODY P IS + FUNCTION F (PARM : ACC_REC_3) RETURN ACC_REC_3 IS + BEGIN + RETURN PARM; + END; + END P; + + PACKAGE NP IS NEW P (ACC_REC => P_REC_NAME, ACC_ARR => P_ARR_NAME); + + USE NP; +BEGIN + TEST ("C38002B", "NON-STATIC CONSTRAINTS CAN BE IMPOSED " & + "ON ACCESS TYPES ACCESSING PREVIOUSLY UNCONSTRAINED " & + "ARRAY OR RECORD TYPES"); + + R := NEW REC(DISC => 3); + R := F(R); + R := NEW REC(DISC => 4); + R := F(R); + FAILED ("INCOMPATIBLE CONSTRAINT ON ACCESS VALUE ACCEPTED " & + "BY GENERIC FUNCTION"); + EXCEPTION + WHEN CONSTRAINT_ERROR => + IF R = NULL OR ELSE R.DISC /= 4 THEN + FAILED (" ERROR IN EVALUATION/ASSIGNMENT OF " & + "GENERIC ACCESS VALUE"); + END IF; + + RESULT; +END C38002B; diff --git a/gcc-4.9/gcc/testsuite/ada/acats/tests/c3/c38005a.ada b/gcc-4.9/gcc/testsuite/ada/acats/tests/c3/c38005a.ada new file mode 100644 index 000000000..75a83a8a8 --- /dev/null +++ b/gcc-4.9/gcc/testsuite/ada/acats/tests/c3/c38005a.ada @@ -0,0 +1,170 @@ +-- C38005A.ADA + +-- Grant of Unlimited Rights +-- +-- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687, +-- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained +-- unlimited rights in the software and documentation contained herein. +-- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making +-- this public release, the Government intends to confer upon all +-- recipients unlimited rights equal to those held by the Government. +-- These rights include rights to use, duplicate, release or disclose the +-- released technical data and computer software in whole or in part, in +-- any manner and for any purpose whatsoever, and to have or permit others +-- to do so. +-- +-- DISCLAIMER +-- +-- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR +-- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED +-- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF 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 ALL (UNINITIALIZED) ACCESS OBJECTS ARE INITIALIZED +-- TO NULL BY DEFAULT. VARIABLES, ARRAYS, RECORDS, ARRAYS OF RECORDS, +-- ARRAYS OF ARRAYS, RECORDS WITH ARRAYS AND RECORD COMPONENTS +-- ARE ALL CHECKED. +-- FUNCTION RESULTS (I.E. RETURNED FROM IMPLICIT FUNCTION RETURN) +-- ARE NOT CHECKED. + +-- DAT 3/6/81 +-- VKG 1/5/83 +-- SPS 2/17/83 + +WITH REPORT; USE REPORT; + +PROCEDURE C38005A IS + + TYPE REC; + TYPE ACC_REC IS ACCESS REC; + TYPE VECTOR IS ARRAY ( NATURAL RANGE <> ) OF ACC_REC; + TYPE REC IS RECORD + VECT : VECTOR (3 .. 5); + END RECORD; + + TYPE ACC_VECT IS ACCESS VECTOR; + TYPE ARR_REC IS ARRAY (1 .. 2) OF REC; + TYPE REC2; + TYPE ACC_REC2 IS ACCESS REC2; + TYPE REC2 IS RECORD + C1 : ACC_REC; + C2 : ACC_VECT; + C3 : ARR_REC; + C4 : REC; + C5 : ACC_REC2; + END RECORD; + + N_REC : REC; + N_ACC_REC : ACC_REC; + N_VEC : VECTOR (3 .. IDENT_INT (5)); + N_ACC_VECT : ACC_VECT; + N_ARR_REC : ARR_REC; + N_REC2 : REC2; + N_ACC_REC2 : ACC_REC2; + N_ARR : ARRAY (1..2) OF VECTOR (1..2); + Q : REC2 := + (C1 => NEW REC, + C2 => NEW VECTOR'(NEW REC, NEW REC'(N_REC)), + C3 => (1 | 2 => (VECT=>(3|4=> NEW REC, + 5=>N_ACC_REC) + )), + C4 => N_REC2.C4, + C5 => NEW REC2'(N_REC2)); + +BEGIN + TEST ("C38005A", "DEFAULT VALUE FOR ACCESS OBJECTS IS NULL"); + + IF N_REC /= REC'(VECT => (3..5 => NULL)) + THEN + FAILED ("INCORRECT ACCESS TYPE INITIALIZATION - 1"); + END IF; + + IF N_ACC_REC /= NULL + THEN + FAILED ("INCORRECT ACCESS TYPE INITIALIZATION - 2"); + END IF; + + IF N_VEC /= N_REC.VECT + THEN + FAILED ("INCORRECT ACCESS TYPE INITIALIZATION - 3"); + END IF; + + IF N_ARR /= ((NULL, NULL), (NULL, NULL)) + THEN + FAILED ("INCORRECT ACCESS TYPE INITIALIZATION - 4"); + END IF; + + IF N_ACC_VECT /= NULL + THEN + FAILED ("INCORRECT ACCESS TYPE INITIALIZATION - 5"); + END IF; + + IF N_ARR_REC /= (N_REC, N_REC) + THEN + FAILED ("INCORRECT ACCESS TYPE INITIALIZATION - 6"); + END IF; + + IF N_REC2 /= (NULL, NULL, N_ARR_REC, N_REC, NULL) + THEN + FAILED ("INCORRECT ACCESS TYPE INITIALIZATION - 7"); + END IF; + + IF N_ACC_REC2 /= NULL + THEN + FAILED ("INCORRECT ACCESS TYPE INITIALIZATION - 8"); + END IF; + + IF Q /= (Q.C1, Q.C2, (Q.C3(1), Q.C3(2)), N_REC, Q.C5) + THEN + FAILED ("INCORRECT ACCESS TYPE INITIALIZATION - 9"); + END IF; + + IF Q.C1.ALL /= N_REC + THEN + FAILED ("INCORRECT ACCESS TYPE INITIALIZATION - 10"); + END IF; + + IF Q.C2.ALL(0).ALL /= N_REC + THEN + FAILED ("INCORRECT ACCESS TYPE INITIALIZATION - 11"); + END IF; + + IF Q.C2(1).VECT /= N_VEC + THEN + FAILED ("INCORRECT ACCESS TYPE INITIALIZATION - 12"); + END IF; + + IF Q.C3(2).VECT /= (3 => Q.C3(2).VECT(3), + 4 => Q.C3(2).VECT(4), + 5=>NULL) + THEN + FAILED ("INCORRECT ACCESS TYPE INITIALIZATION - 13"); + END IF; + + IF Q.C3(2).VECT(3).ALL /= N_REC + THEN + FAILED ("INCORRECT ACCESS TYPE INITIALIZATION - 14"); + END IF; + + IF Q.C5.ALL /= N_REC2 + THEN + FAILED ("INCORRECT ACCESS TYPE INITIALIZATION - 15"); + END IF; + + DECLARE + PROCEDURE T (R : OUT REC2) IS + BEGIN + NULL; + END T; + BEGIN + N_REC2 := Q; + T(Q); + IF Q /= N_REC2 THEN + FAILED ("INCORRECT OUT PARM INIT 2"); + END IF; + END; + + RESULT; +END C38005A; diff --git a/gcc-4.9/gcc/testsuite/ada/acats/tests/c3/c38005b.ada b/gcc-4.9/gcc/testsuite/ada/acats/tests/c3/c38005b.ada new file mode 100644 index 000000000..1c2770425 --- /dev/null +++ b/gcc-4.9/gcc/testsuite/ada/acats/tests/c3/c38005b.ada @@ -0,0 +1,98 @@ +-- C38005B.ADA + +-- Grant of Unlimited Rights +-- +-- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687, +-- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained +-- unlimited rights in the software and documentation contained herein. +-- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making +-- this public release, the Government intends to confer upon all +-- recipients unlimited rights equal to those held by the Government. +-- These rights include rights to use, duplicate, release or disclose the +-- released technical data and computer software in whole or in part, in +-- any manner and for any purpose whatsoever, and to have or permit others +-- to do so. +-- +-- DISCLAIMER +-- +-- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR +-- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED +-- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE +-- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE +-- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A +-- PARTICULAR PURPOSE OF SAID MATERIAL. +--* +-- OBJECTIVE: +-- CHECK THAT ANY OBJECT WITH A FORMAL PRIVATE TYPE, WHOSE ACTUAL +-- TYPE IN AN INSTANTIATION IS AN ACCESS TYPE, IS INITIALIZED BY +-- DEFAULT TO THE VALUE NULL. THIS INCLUDES OBJECTS WHICH ARE ARRAY +-- AND RECORD COMPONENTS. + +-- HISTORY: +-- DHH 07/12/88 CREATED ORIGINAL TEST. + +WITH REPORT; USE REPORT; +PROCEDURE C38005B IS + +BEGIN + TEST("C38005B", "CHECK THAT ANY OBJECT WITH A FORMAL PRIVATE " & + "TYPE, WHOSE ACTUAL TYPE IN AN INSTANTIATION " & + "IS AN ACCESS TYPE, IS INITIALIZED BY DEFAULT " & + "TO THE VALUE NULL. THIS INCLUDES OBJECTS WHICH " & + "ARE ARRAY AND RECORD COMPONENTS"); + DECLARE + TYPE ARRY IS ARRAY(1 .. 10) OF BOOLEAN; + TYPE REC1 IS + RECORD + A : INTEGER; + B : ARRY; + END RECORD; + + TYPE POINTER IS ACCESS REC1; + + GENERIC + TYPE NEW_PTR IS PRIVATE; + PACKAGE GEN_PACK IS + TYPE PTR_ARY IS ARRAY(1 .. 5) OF NEW_PTR; + TYPE RECORD1 IS + RECORD + A : NEW_PTR; + B : PTR_ARY; + END RECORD; + + OBJ : NEW_PTR; + ARY : PTR_ARY; + REC : RECORD1; + END GEN_PACK; + + PACKAGE TEST_P IS NEW GEN_PACK(POINTER); + USE TEST_P; + + BEGIN + IF OBJ /= NULL THEN + FAILED("OBJECT NOT INITIALIZED TO NULL"); + END IF; + + FOR I IN 1 .. 5 LOOP + IF ARY(I) /= NULL THEN + FAILED("ARRAY COMPONENT " & + INTEGER'IMAGE(I) & + " NOT INITIALIZED TO NULL"); + END IF; + END LOOP; + + IF REC.A /= NULL THEN + FAILED("RECORD OBJECT NOT INITIALIZED TO NULL"); + END IF; + + FOR I IN 1 .. 5 LOOP + IF REC.B(I) /= NULL THEN + FAILED("RECORD SUBCOMPONENT " & + INTEGER'IMAGE(I) & + " NOT INITIALIZED TO NULL"); + END IF; + END LOOP; + END; + + RESULT; +END C38005B; diff --git a/gcc-4.9/gcc/testsuite/ada/acats/tests/c3/c38005c.ada b/gcc-4.9/gcc/testsuite/ada/acats/tests/c3/c38005c.ada new file mode 100644 index 000000000..5512ecbbf --- /dev/null +++ b/gcc-4.9/gcc/testsuite/ada/acats/tests/c3/c38005c.ada @@ -0,0 +1,156 @@ +-- C38005C.ADA + +-- Grant of Unlimited Rights +-- +-- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687, +-- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained +-- unlimited rights in the software and documentation contained herein. +-- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making +-- this public release, the Government intends to confer upon all +-- recipients unlimited rights equal to those held by the Government. +-- These rights include rights to use, duplicate, release or disclose the +-- released technical data and computer software in whole or in part, in +-- any manner and for any purpose whatsoever, and to have or permit others +-- to do so. +-- +-- DISCLAIMER +-- +-- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR +-- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED +-- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF 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 ALL OBJECTS OF FORMAL ACCESS TYPE, INCLUDING ARRAY AND +-- RECORD COMPONENTS, ARE INITIALIZED BY DEFAULT WITH THE VALUE +-- NULL. + +-- HISTORY: +-- DHH 08/04/88 CREATED ORIGINAL TEST. + +WITH REPORT; USE REPORT; +PROCEDURE C38005C IS + + SUBTYPE INT IS INTEGER RANGE 1 .. 10; + + TYPE ACC_I IS ACCESS INT; + + SUBTYPE NEW_NODE IS CHARACTER; + + TYPE ACC_CHAR IS ACCESS NEW_NODE; + + X : ACC_I := NEW INT'(IDENT_INT(5)); + Y : NEW_NODE := 'A'; + Z : ACC_CHAR := NEW NEW_NODE'(Y); + + GENERIC + TYPE ACC_INT IS ACCESS INT; + TYPE NODE IS PRIVATE; + TYPE LINK IS ACCESS NODE; + PROCEDURE P(U : ACC_INT; V : NODE; W : LINK); + + GENERIC + TYPE ACC_INT IS ACCESS INT; + TYPE NODE IS PRIVATE; + TYPE LINK IS ACCESS NODE; + PACKAGE PACK IS + + SUBTYPE NEW_ACC IS ACC_INT; + + SUBTYPE NEW_L IS LINK; + + TYPE ARR IS ARRAY(1 .. 4) OF ACC_INT; + + TYPE REC IS + RECORD + I : ACC_INT; + L : LINK; + END RECORD; + + END PACK; + + PACKAGE NEW_PACK IS NEW PACK(ACC_I, NEW_NODE, ACC_CHAR); + USE NEW_PACK; + + A : NEW_PACK.NEW_ACC; + B : NEW_PACK.NEW_L; + C : NEW_PACK.ARR; + D : NEW_PACK.REC; + + PROCEDURE P(U : ACC_INT; V : NODE; W : LINK) IS + + TYPE ARR IS ARRAY(1 .. 4) OF ACC_INT; + + TYPE REC IS + RECORD + I : ACC_INT; + L : LINK; + END RECORD; + + A : ACC_INT; + B : LINK; + C : ARR; + D : REC; + + BEGIN + IF A /= NULL THEN + FAILED("OBJECT A NOT INITIALIZED - PROC"); + END IF; + + IF B /= NULL THEN + FAILED("OBJECT B NOT INITIALIZED - PROC"); + END IF; + + FOR I IN 1 .. 4 LOOP + IF C(I) /= NULL THEN + FAILED("ARRAY " & INTEGER'IMAGE(I) & + "NOT INITIALIZED - PROC"); + END IF; + END LOOP; + + IF D.I /= NULL THEN + FAILED("RECORD.I NOT INITIALIZED - PROC"); + END IF; + + IF D.L /= NULL THEN + FAILED("RECORD.L NOT INITIALIZED - PROC"); + END IF; + + END P; + + PROCEDURE PROC IS NEW P(ACC_I, NEW_NODE, ACC_CHAR); + +BEGIN + TEST("C38005C", "CHECK THAT ALL OBJECTS OF FORMAL ACCESS TYPE, " & + "INCLUDING ARRAY AND RECORD COMPONENTS, ARE " & + "INITIALIZED BY DEFAULT WITH THE VALUE NULL"); + + PROC(X, Y, Z); + + IF A /= NULL THEN + FAILED("OBJECT A NOT INITIALIZED - PACK"); + END IF; + + IF B /= NULL THEN + FAILED("OBJECT B NOT INITIALIZED - PACK"); + END IF; + + FOR I IN 1 .. 4 LOOP + IF C(I) /= NULL THEN + FAILED("ARRAY " & INTEGER'IMAGE(I) & + "NOT INITIALIZED - PACK"); + END IF; + END LOOP; + + IF D.I /= NULL THEN + FAILED("RECORD.I NOT INITIALIZED - PACK"); + END IF; + + IF D.L /= NULL THEN + FAILED("RECORD.L NOT INITIALIZED - PACK"); + END IF; + + RESULT; +END C38005C; diff --git a/gcc-4.9/gcc/testsuite/ada/acats/tests/c3/c38006a.ada b/gcc-4.9/gcc/testsuite/ada/acats/tests/c3/c38006a.ada new file mode 100644 index 000000000..a4f0c90db --- /dev/null +++ b/gcc-4.9/gcc/testsuite/ada/acats/tests/c3/c38006a.ada @@ -0,0 +1,50 @@ +-- C38006A.ADA + +-- Grant of Unlimited Rights +-- +-- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687, +-- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained +-- unlimited rights in the software and documentation contained herein. +-- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making +-- this public release, the Government intends to confer upon all +-- recipients unlimited rights equal to those held by the Government. +-- These rights include rights to use, duplicate, release or disclose the +-- released technical data and computer software in whole or in part, in +-- any manner and for any purpose whatsoever, and to have or permit others +-- to do so. +-- +-- DISCLAIMER +-- +-- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR +-- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED +-- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF 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 OBJECTS ACCESSED BY CONSTANTS CAN BE MODIFIED. + +-- DAT 3/6/81 +-- SPS 10/25/82 + +WITH REPORT; USE REPORT; + +PROCEDURE C38006A IS + + TYPE AI IS ACCESS INTEGER; + + C : CONSTANT AI := NEW INTEGER'(1); + +BEGIN + TEST ("C38006A", "OBJECTS ACCESSED BY CONSTANTS MAY BE ASSIGNED"); + + FOR I IN 1 .. 10 LOOP + IF C.ALL /= I AND I > 1 THEN + FAILED ("OBJECT ACCESSED THRU CONSTANT NOT CHANGED"); + EXIT; + END IF; + C.ALL := C.ALL + 1; + END LOOP; + + RESULT; +END C38006A; diff --git a/gcc-4.9/gcc/testsuite/ada/acats/tests/c3/c38102a.ada b/gcc-4.9/gcc/testsuite/ada/acats/tests/c3/c38102a.ada new file mode 100644 index 000000000..32649abcd --- /dev/null +++ b/gcc-4.9/gcc/testsuite/ada/acats/tests/c3/c38102a.ada @@ -0,0 +1,158 @@ +-- C38102A.ADA + +-- Grant of Unlimited Rights +-- +-- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687, +-- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained +-- unlimited rights in the software and documentation contained herein. +-- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making +-- this public release, the Government intends to confer upon all +-- recipients unlimited rights equal to those held by the Government. +-- These rights include rights to use, duplicate, release or disclose the +-- released technical data and computer software in whole or in part, in +-- any manner and for any purpose whatsoever, and to have or permit others +-- to do so. +-- +-- DISCLAIMER +-- +-- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR +-- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED +-- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF 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 INCOMPLETE TYPE DECLARATION CAN BE GIVEN FOR ANY TYPE. +-- FULL DECLARATIONS FOR INTEGER, ENUMERATION, CONSTRAINED AND +-- UNCONSTRAINED ARRAYS, RECORDS WITHOUT DISCRIMINANTS, +-- AN ACCESS TYPE, OR TYPES DERIVED FROM ANY OF THE ABOVE. + +-- (FLOAT, FIXED, TASKS AND RECORDS WITH DISCRIMINANTS ARE CHECKED +-- IN OTHER TESTS). + +-- DAT 3/24/81 +-- SPS 10/25/82 +-- SPS 2/17/82 + +WITH REPORT; USE REPORT; + +PROCEDURE C38102A IS +BEGIN + TEST ("C38102A", "ANY TYPE MAY BE INCOMPLETE"); + + DECLARE + + TYPE X1; + TYPE X2; + TYPE X3; + TYPE X4; + TYPE X5; + TYPE X6; + TYPE X7; + TYPE X8; + + TYPE D1; + TYPE D2; + TYPE D3; + TYPE D4; + TYPE D5; + TYPE D6; + + TYPE X1 IS RANGE 1 .. 10; + TYPE X2 IS (TRUE, FALSE, MAYBE, GREEN); + TYPE X3 IS ARRAY (1 .. 3) OF STRING (1..10); + TYPE X4 IS ARRAY (NATURAL RANGE <> ) OF X3; + TYPE AR1 IS ARRAY (X2) OF X3; + TYPE X5 IS RECORD + C1 : X4 (1..3); + C2 : AR1; + END RECORD; + TYPE X6 IS ACCESS X8; + TYPE X7 IS ACCESS X6; + TYPE X8 IS ACCESS X6; + + TYPE D1 IS NEW X1; + TYPE D2 IS NEW X2; + TYPE D3 IS NEW X3; + TYPE D4 IS NEW X4; + TYPE D5 IS NEW X5; + SUBTYPE D7 IS X7; + SUBTYPE D8 IS X8; + TYPE D6 IS ACCESS D8; + + PACKAGE P IS + + TYPE X1; + TYPE X2; + TYPE X3; + TYPE X4; + TYPE X5; + TYPE X6; + TYPE X7 IS PRIVATE; + TYPE X8 IS LIMITED PRIVATE; + + TYPE D1; + TYPE D2; + TYPE D3; + TYPE D4; + TYPE D5; + TYPE D6; + + TYPE X1 IS RANGE 1 .. 10; + TYPE X2 IS (TRUE, FALSE, MAYBE, GREEN); + TYPE X3 IS ARRAY (1 .. 3) OF STRING (1..10); + TYPE X4 IS ARRAY (NATURAL RANGE <> ) OF X3; + TYPE AR1 IS ARRAY (X2) OF X3; + TYPE X5 IS RECORD + C1 : X4 (1..3); + C2 : AR1; + END RECORD; + TYPE X6 IS ACCESS X8; + + TYPE D1 IS RANGE 1 .. 10; + TYPE D2 IS NEW X2; + TYPE D3 IS NEW X3; + TYPE D4 IS NEW X4; + TYPE D5 IS NEW X5; + TYPE D6 IS NEW X6; + SUBTYPE D7 IS X7; + SUBTYPE D8 IS X8; + TYPE D9 IS ACCESS D8; + + VX7 : CONSTANT X7; + + PRIVATE + + TYPE X7 IS RECORD + C1 : X1; + C3 : X3; + C5 : X5; + C6 : X6; + C8 : D9; + END RECORD; + + V3 : X3 := (X3'RANGE => "ABCDEFGHIJ"); + TYPE A7 IS ACCESS X7; + TYPE X8 IS ARRAY (V3'RANGE) OF A7; + + VX7 : CONSTANT X7 := (3, V3, ((1..3=>V3), + (TRUE..GREEN=>V3)), NULL, + NEW D8); + END P; + USE P; + + VD7: P.D7; + + PACKAGE BODY P IS + BEGIN + VD7 := D7(VX7); + END P; + + BEGIN + IF VX7 /= P.X7(VD7) THEN + FAILED ("WRONG VALUE SOMEWHERE"); + END IF; + END; + + RESULT; +END C38102A; diff --git a/gcc-4.9/gcc/testsuite/ada/acats/tests/c3/c38102b.ada b/gcc-4.9/gcc/testsuite/ada/acats/tests/c3/c38102b.ada new file mode 100644 index 000000000..c9e4bc272 --- /dev/null +++ b/gcc-4.9/gcc/testsuite/ada/acats/tests/c3/c38102b.ada @@ -0,0 +1,56 @@ +-- C38102B.ADA + +-- Grant of Unlimited Rights +-- +-- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687, +-- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained +-- unlimited rights in the software and documentation contained herein. +-- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making +-- this public release, the Government intends to confer upon all +-- recipients unlimited rights equal to those held by the Government. +-- These rights include rights to use, duplicate, release or disclose the +-- released technical data and computer software in whole or in part, in +-- any manner and for any purpose whatsoever, and to have or permit others +-- to do so. +-- +-- DISCLAIMER +-- +-- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR +-- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED +-- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF 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 INCOMPLETE TYPES CAN BE FLOAT. + +-- DAT 3/24/81 +-- SPS 10/25/82 + +WITH REPORT; USE REPORT; + +PROCEDURE C38102B IS + +BEGIN + TEST ("C38102B", "INCOMPLETE TYPE CAN BE FLOAT"); + + DECLARE + + TYPE F; + TYPE G; + TYPE AF IS ACCESS F; + TYPE F IS DIGITS 2; + TYPE G IS NEW F RANGE 1.0 .. 1.5; + TYPE AG IS ACCESS G RANGE 1.0 .. 1.3; + + XF : AF := NEW F' (2.0); + XG : AG := NEW G' (G (XF.ALL/2.0)); + + BEGIN + IF XG.ALL NOT IN G THEN + FAILED ("ACCESS TO FLOAT"); + END IF; + END; + + RESULT; +END C38102B; diff --git a/gcc-4.9/gcc/testsuite/ada/acats/tests/c3/c38102c.ada b/gcc-4.9/gcc/testsuite/ada/acats/tests/c3/c38102c.ada new file mode 100644 index 000000000..a4128ae98 --- /dev/null +++ b/gcc-4.9/gcc/testsuite/ada/acats/tests/c3/c38102c.ada @@ -0,0 +1,60 @@ +-- C38102C.ADA + +-- Grant of Unlimited Rights +-- +-- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687, +-- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained +-- unlimited rights in the software and documentation contained herein. +-- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making +-- this public release, the Government intends to confer upon all +-- recipients unlimited rights equal to those held by the Government. +-- These rights include rights to use, duplicate, release or disclose the +-- released technical data and computer software in whole or in part, in +-- any manner and for any purpose whatsoever, and to have or permit others +-- to do so. +-- +-- DISCLAIMER +-- +-- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR +-- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED +-- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF 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 INCOMPLETE TYPES CAN BE FIXED. + +-- HISTORY: +-- DAT 03/24/81 CREATED ORIGINAL TEST. +-- SPS 10/25/82 +-- BCB 10/21/87 CHANGED HEADER TO STANDARD FORMAT. CHANGED VARIOUS +-- VALUES TO CORRECT CONSTRAINT PROBLEMS. CHANGED +-- THE VALUE OF F'DELTA, USING A POWER OF TWO. + +WITH REPORT; USE REPORT; + +PROCEDURE C38102C IS +BEGIN + TEST ("C38102C", "INCOMPLETE TYPE CAN BE FIXED"); + + DECLARE + + TYPE F; + TYPE G; + TYPE AF IS ACCESS F; + TYPE F IS DELTA 0.25 RANGE -2.0 .. 2.0; + TYPE G IS NEW F RANGE -1.0 .. 1.5; + TYPE AG IS ACCESS G RANGE -0.75 .. 1.25; + + XF : AF := NEW F '(1.0); + XG : AG := NEW G '(G (XF.ALL/2)); + + BEGIN + IF XG.ALL NOT IN G THEN + FAILED ("ACCESS TO FIXED"); + END IF; + END; + + RESULT; +END C38102C; diff --git a/gcc-4.9/gcc/testsuite/ada/acats/tests/c3/c38102d.ada b/gcc-4.9/gcc/testsuite/ada/acats/tests/c3/c38102d.ada new file mode 100644 index 000000000..60361272e --- /dev/null +++ b/gcc-4.9/gcc/testsuite/ada/acats/tests/c3/c38102d.ada @@ -0,0 +1,54 @@ +-- C38102D.ADA + +-- Grant of Unlimited Rights +-- +-- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687, +-- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained +-- unlimited rights in the software and documentation contained herein. +-- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making +-- this public release, the Government intends to confer upon all +-- recipients unlimited rights equal to those held by the Government. +-- These rights include rights to use, duplicate, release or disclose the +-- released technical data and computer software in whole or in part, in +-- any manner and for any purpose whatsoever, and to have or permit others +-- to do so. +-- +-- DISCLAIMER +-- +-- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR +-- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED +-- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF 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 INCOMPLETE TYPE CAN BE REDECLARED AS A TASK TYPE. + +-- AH 8/14/86 + +WITH REPORT; USE REPORT; +PROCEDURE C38102D IS + GLOBAL : INTEGER := 0; +BEGIN + TEST("C38102D", "INCOMPLETE TYPES CAN BE TASKS"); + DECLARE + TYPE T1; + TASK TYPE T1 IS + ENTRY E(LOCAL : IN OUT INTEGER); + END T1; + T1_OBJ : T1; + TASK BODY T1 IS + BEGIN + ACCEPT E(LOCAL : IN OUT INTEGER) DO + LOCAL := IDENT_INT(2); + END E; + END T1; + BEGIN + T1_OBJ.E(GLOBAL); + END; + + IF GLOBAL /= IDENT_INT(2) THEN + FAILED ("TASK NOT EXECUTED"); + END IF; + RESULT; +END C38102D; diff --git a/gcc-4.9/gcc/testsuite/ada/acats/tests/c3/c38102e.ada b/gcc-4.9/gcc/testsuite/ada/acats/tests/c3/c38102e.ada new file mode 100644 index 000000000..6ffec0599 --- /dev/null +++ b/gcc-4.9/gcc/testsuite/ada/acats/tests/c3/c38102e.ada @@ -0,0 +1,164 @@ +-- C38102E.ADA + +-- Grant of Unlimited Rights +-- +-- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687, +-- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained +-- unlimited rights in the software and documentation contained herein. +-- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making +-- this public release, the Government intends to confer upon all +-- recipients unlimited rights equal to those held by the Government. +-- These rights include rights to use, duplicate, release or disclose the +-- released technical data and computer software in whole or in part, in +-- any manner and for any purpose whatsoever, and to have or permit others +-- to do so. +-- +-- DISCLAIMER +-- +-- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR +-- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED +-- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF 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 INCOMPLETE TYPE CAN BE REDECLARED AS A DERIVED GENERIC +-- FORMAL TYPE. + +-- AH 8/15/86 +-- PWN 01/31/95 REMOVED INCONSISTENCIES WITH ADA 9X. +-- DNT 11/28/95 CHANGED TO FLAG1 := F4. + +WITH REPORT; USE REPORT; +PROCEDURE C38102E IS + TYPE RAINBOW IS (RED, ORANGE, YELLOW, GREEN, BLUE, INDIGO, VIOLET); + TYPE T_FLOAT IS DIGITS 5 RANGE -4.0 .. 4.0; + TYPE T_FIXED IS DELTA 0.01 RANGE 0.0 .. 1.5; + SUBTYPE P1 IS INTEGER; + TYPE P2 IS RANGE 0 .. 10; + TYPE P3 IS ARRAY (P2) OF INTEGER; + TYPE P4 IS ARRAY (P2, P2) OF INTEGER; + + F1, F2 : BOOLEAN; + + GENERIC + TYPE G1 IS (<>); + TYPE G2 IS RANGE <>; + FUNCTION G_DISCRETE RETURN BOOLEAN; + + FUNCTION G_DISCRETE RETURN BOOLEAN IS + TYPE INC1; + TYPE INC2; + TYPE F1 IS NEW G1; + TYPE INC1 IS NEW G1; + TYPE INC2 IS NEW G2; + + OBJ1_0 : INC1; + OBJ1_1 : INC1; + OBJ2_0 : INC2; + OBJ2_1 : INC2; + OBJ3 : F1; + + RESULT_VALUE1 : BOOLEAN := FALSE; + RESULT_VALUE2 : BOOLEAN := FALSE; + BEGIN + OBJ3 := F1'LAST; + OBJ3 := F1'PRED(OBJ3); + IF INC1(OBJ3) = INC1'PRED(INC1'LAST) THEN + RESULT_VALUE1 := TRUE; + END IF; + OBJ2_0 := INC2'FIRST; + OBJ2_1 := INC2'LAST; + IF (OBJ2_0 + OBJ2_1) = (INC2'SUCC(OBJ2_0) + + INC2'PRED(OBJ2_1)) THEN + RESULT_VALUE2 := TRUE; + END IF; + + RETURN (RESULT_VALUE1 AND RESULT_VALUE2); + END G_DISCRETE; + + GENERIC + TYPE G3 IS DIGITS <>; + TYPE G4 IS DELTA <>; + PROCEDURE REALS (FLAG1, FLAG2 : OUT BOOLEAN); + + PROCEDURE REALS (FLAG1, FLAG2 : OUT BOOLEAN) IS + F1, F2, F3, F4, F5, F6, F7, F8 : BOOLEAN; + TYPE INC3; + TYPE INC4; + TYPE P1 IS NEW G3; + TYPE P2 IS NEW G4; + TYPE INC3 IS NEW G3; + TYPE INC4 IS NEW G4; + BEGIN + F4 := P1'LAST = P1(INC3'LAST) AND P1'FIRST = P1(INC3'FIRST); + + F5 := P2'FORE = INC4'FORE; + F6 := P2'AFT = INC4'AFT; + F7 := ABS(P2'LAST - P2'FIRST) = P2(ABS(INC4'LAST - + INC4'FIRST)); + F8 := INC4(P2'LAST / P2'LAST) = INC4(INC4'LAST / INC4'LAST); + + FLAG1 := F4; + FLAG2 := F5 AND F6 AND F7 AND F8; + END REALS; + + GENERIC + TYPE ITEM IS PRIVATE; + TYPE INDEX IS RANGE <>; + TYPE G5 IS ARRAY (INDEX) OF ITEM; + TYPE G6 IS ARRAY (INDEX, INDEX) OF ITEM; + PACKAGE DIMENSIONS IS + TYPE INC5; + TYPE INC6; + TYPE D1 IS NEW G5; + TYPE D2 IS NEW G6; + TYPE INC5 IS NEW G5; + TYPE INC6 IS NEW G6; + FUNCTION CHECK RETURN BOOLEAN; + END DIMENSIONS; + + PACKAGE BODY DIMENSIONS IS + FUNCTION CHECK RETURN BOOLEAN IS + A1 : INC5; + A2 : INC6; + DIM1 : D1; + DIM2 : D2; + F1, F2 : BOOLEAN; + BEGIN + F1 := A1(INDEX'FIRST)'SIZE = DIM1(INDEX'FIRST)'SIZE; + F2 := A2(INDEX'FIRST, INDEX'LAST)'SIZE = + DIM2(INDEX'FIRST, INDEX'LAST)'SIZE; + + RETURN (F1 AND F2); + END CHECK; + END DIMENSIONS; + + PROCEDURE PROC IS NEW REALS (G3 => T_FLOAT, G4 => T_FIXED); + FUNCTION DISCRETE IS NEW G_DISCRETE (G1 => RAINBOW, G2 => P2); + PACKAGE PKG IS NEW DIMENSIONS (ITEM => P1, INDEX => P2, G5 => P3, + G6 => P4); + + USE PKG; +BEGIN + TEST ("C38102E", "INCOMPLETE TYPES CAN BE DERIVED GENERIC " & + "FORMAL TYPES"); + + IF NOT DISCRETE THEN + FAILED ("INTEGER AND ENUMERATED TYPES NOT DERIVED"); + END IF; + + PROC (F1, F2); + IF (NOT F1) THEN + FAILED ("FLOAT TYPES NOT DERIVED"); + END IF; + IF (NOT F2) THEN + FAILED ("FIXED TYPES NOT DERIVED"); + END IF; + + IF NOT CHECK THEN + FAILED ("ONE AND TWO DIMENSIONAL ARRAY TYPES NOT DERIVED"); + END IF; + + RESULT; +END C38102E; diff --git a/gcc-4.9/gcc/testsuite/ada/acats/tests/c3/c38104a.ada b/gcc-4.9/gcc/testsuite/ada/acats/tests/c3/c38104a.ada new file mode 100644 index 000000000..f5f2873af --- /dev/null +++ b/gcc-4.9/gcc/testsuite/ada/acats/tests/c3/c38104a.ada @@ -0,0 +1,97 @@ +-- C38104A.ADA + +-- Grant of Unlimited Rights +-- +-- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687, +-- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained +-- unlimited rights in the software and documentation contained herein. +-- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making +-- this public release, the Government intends to confer upon all +-- recipients unlimited rights equal to those held by the Government. +-- These rights include rights to use, duplicate, release or disclose the +-- released technical data and computer software in whole or in part, in +-- any manner and for any purpose whatsoever, and to have or permit others +-- to do so. +-- +-- DISCLAIMER +-- +-- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR +-- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED +-- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF 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 INCOMPLETE TYPE WITH DISCRIMINANTS CAN BE +-- USED IN AN ACCESS TYPE DEFINITION WITH A COMPATIBLE DISCRIMINANT +-- CONSTRAINT. + +-- HISTORY: +-- PMW 09/01/88 CREATED ORIGINAL TEST BY RENAMING E38104A.ADA. + +WITH REPORT; USE REPORT; +PROCEDURE C38104A IS + +BEGIN + + TEST ("C38104A","INCOMPLETELY DECLARED TYPE CAN BE USED AS TYPE " & + "MARK IN ACCESS TYPE DEFINITION, AND CAN BE CONSTRAINED " & + "THERE OR LATER IF INCOMPLETE TYPE HAD DISCRIMINANT(S)"); + + DECLARE + TYPE T1; + TYPE T1_NAME IS ACCESS T1; + + TYPE T1 IS + RECORD + COMP : INTEGER; + END RECORD; + + TYPE T2(DISC : INTEGER := 5); + TYPE T2_NAME1 IS ACCESS T2(5); + TYPE T2_NAME2 IS ACCESS T2; + + SUBTYPE SUB_T2_NAME2 IS T2_NAME2(5); + TYPE T2_NAME2_NAME IS ACCESS T2_NAME2(5); + X : T2_NAME2(5); + + TYPE T2(DISC : INTEGER := 5) IS + RECORD + COMP : T2_NAME2(DISC); + END RECORD; + + X1N : T1_NAME; + X2A,X2B : T2; + X2N2 : T2_NAME2; + + BEGIN + IF EQUAL(3,3) THEN + X1N := NEW T1 '(COMP => 5); + END IF; + + IF X1N.COMP /= 5 THEN + FAILED ("ASSIGNMENT FAILED - 1"); + END IF; + + X2A := (DISC => IDENT_INT(7), COMP => NULL); + X2N2 := NEW T2(IDENT_INT(7)); + X2N2.ALL := X2A; + + IF EQUAL(3,3) THEN + X2B := (DISC => IDENT_INT(7), COMP => X2N2); + END IF; + + IF X2B.COMP.COMP /= NULL + OR X2B.COMP.DISC /= 7 THEN + FAILED ("ASSIGNMENT FAILED - 2"); + END IF; + + EXCEPTION + WHEN OTHERS => + FAILED ("EXCEPTION RAISED"); + END; + + RESULT; + +END C38104A; diff --git a/gcc-4.9/gcc/testsuite/ada/acats/tests/c3/c38107a.ada b/gcc-4.9/gcc/testsuite/ada/acats/tests/c3/c38107a.ada new file mode 100644 index 000000000..75a2492d6 --- /dev/null +++ b/gcc-4.9/gcc/testsuite/ada/acats/tests/c3/c38107a.ada @@ -0,0 +1,105 @@ +-- C38107A.ADA + +-- Grant of Unlimited Rights +-- +-- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687, +-- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained +-- unlimited rights in the software and documentation contained herein. +-- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making +-- this public release, the Government intends to confer upon all +-- recipients unlimited rights equal to those held by the Government. +-- These rights include rights to use, duplicate, release or disclose the +-- released technical data and computer software in whole or in part, in +-- any manner and for any purpose whatsoever, and to have or permit others +-- to do so. +-- +-- DISCLAIMER +-- +-- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR +-- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED +-- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE +-- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE +-- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A +-- PARTICULAR PURPOSE OF SAID MATERIAL. +--* +-- OBJECTIVE: +-- FOR AN INCOMPLETE TYPE WITH DISCRIMINANTS DECLARED IN THE +-- VISIBLE PART OF A PACKAGE OR IN A DECLARATIVE PART, CHECK THAT +-- CONSTRAINT_ERROR IS RAISED IF A DISCRIMINANT CONSTRAINT IS +-- SPECIFIED FOR THE TYPE AND ONE OF THE DISCRIMINANT VALUES DOES +-- NOT BELONG TO THE CORRESPONDING DISCRIMINANT'S SUBTYPE. + +-- HISTORY: +-- BCB 01/21/88 CREATED ORIGINAL TEST. + +WITH REPORT; USE REPORT; + +PROCEDURE C38107A IS + +BEGIN + TEST ("C38107A", "FOR AN INCOMPLETE TYPE WITH DISCRIMINANTS " & + "DECLARED IN THE VISIBLE PART OF A PACKAGE OR " & + "IN A DECLARATIVE PART, CHECK THAT CONSTRAINT_" & + "ERROR IS RAISED IF A DISCRIMINANT CONSTRAINT " & + "IS SPECIFIED FOR THE TYPE AND ONE OF THE " & + "DISCRIMINANT VALUES DOES NOT BELONG TO THE " & + "CORRESPONDING DISCRIMINANT'S SUBTYPE"); + + BEGIN + DECLARE + PACKAGE P IS + SUBTYPE INT6 IS INTEGER RANGE 1 .. 6; + TYPE T_INT6 (D6 : INT6); + TYPE TEST IS ACCESS T_INT6(7); -- CONSTRAINT_ERROR. + TYPE T_INT6 (D6 : INT6) IS + RECORD + NULL; + END RECORD; + END P; + USE P; + BEGIN + FAILED ("CONSTRAINT_ERROR WAS NOT RAISED - 1"); + DECLARE + T : P.TEST := NEW T_INT6(7); + BEGIN + IF EQUAL(T.D6, T.D6) THEN + COMMENT ("DON'T OPTIMIZE T.D6"); + END IF; + END; + END; + EXCEPTION + WHEN CONSTRAINT_ERROR => + NULL; + WHEN OTHERS => + FAILED ("AN EXCEPTION OTHER THAN CONSTRAINT_ERROR " & + "WAS RAISED - 1"); + END; + + BEGIN + DECLARE + SUBTYPE INT7 IS INTEGER RANGE 1 .. 7; + TYPE T_INT7 (D7 : INT7); + TYPE TEST IS ACCESS T_INT7(8); -- CONSTRAINT_ERROR. + TYPE T_INT7 (D7 : INT7) IS + RECORD + NULL; + END RECORD; + BEGIN + FAILED ("CONSTRAINT_ERROR WAS NOT RAISED - 2"); + DECLARE + T : TEST := NEW T_INT7(6); + BEGIN + IF EQUAL(T.D7, T.D7) THEN + COMMENT ("DON'T OPTIMIZE T.D7"); + END IF; + END; + END; + EXCEPTION + WHEN CONSTRAINT_ERROR => + NULL; + WHEN OTHERS => + FAILED ("AN EXCEPTION OTHER THAN CONSTRAINT_ERROR " & + "WAS RAISED - 2"); + END; + RESULT; +END C38107A; diff --git a/gcc-4.9/gcc/testsuite/ada/acats/tests/c3/c38107b.ada b/gcc-4.9/gcc/testsuite/ada/acats/tests/c3/c38107b.ada new file mode 100644 index 000000000..8e74581f3 --- /dev/null +++ b/gcc-4.9/gcc/testsuite/ada/acats/tests/c3/c38107b.ada @@ -0,0 +1,194 @@ +-- C38107B.ADA + +-- Grant of Unlimited Rights +-- +-- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687, +-- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained +-- unlimited rights in the software and documentation contained herein. +-- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making +-- this public release, the Government intends to confer upon all +-- recipients unlimited rights equal to those held by the Government. +-- These rights include rights to use, duplicate, release or disclose the +-- released technical data and computer software in whole or in part, in +-- any manner and for any purpose whatsoever, and to have or permit others +-- to do so. +-- +-- DISCLAIMER +-- +-- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR +-- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED +-- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF 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: +-- IF A DISCRIMINANT CONSTRAINT IS APPLIED TO AN ACCESS TYPE WHICH +-- DESIGNATES AN INCOMPLETE TYPE WHICH WAS DECLARED IN THE VISIBLE +-- OR PRIVATE PART OF A PACKAGE SPECIFICATION, OR IN A DECLARATIVE +-- PART, CONSTRAINT_ERROR IS RAISED IF ONE OF THE +-- DISCRIMINANT'S VALUES DOES NOT BELONG TO THE CORRESPONDING +-- DISCRIMINANT'S SUBTYPE. + +-- HISTORY: +-- DHH 08/05/88 CREATED ORIGINAL TEST. + +WITH REPORT; USE REPORT; +PROCEDURE C38107B IS + +BEGIN + TEST("C38107B", "IF A DISCRIMINANT CONSTRAINT IS APPLIED TO AN " & + "ACCESS TYPE WHICH DESIGNATES AN INCOMPLETE " & + "TYPE WHICH WAS DECLARED IN THE VISIBLE OR " & + "PRIVATE PART OF A PACKAGE SPECIFICATION, OR IN " & + "A DECLARATIVE PART, CONSTRAINT_ERROR IS " & + "RAISED IF ONE OF THE DISCRIMINANT'S VALUES " & + "DOES NOT BELONG TO THE CORRESPONDING " & + "DISCRIMINANT'S SUBTYPE"); + +------------------------------ VISIBLE ------------------------------ + BEGIN + DECLARE + PACKAGE PACK IS + SUBTYPE SMALLER IS INTEGER RANGE 1 .. 5; + + TYPE INCOMPLETE(A : SMALLER); + + TYPE ACC_INC IS ACCESS INCOMPLETE; + SUBTYPE SUB_ACC IS ACC_INC(IDENT_INT(6)); + + TYPE INCOMPLETE(A : SMALLER) IS + RECORD + T : INTEGER := A; + END RECORD; + + END PACK; + + PACKAGE BODY PACK IS + BEGIN + FAILED("CONSTRAINT_ERROR NOT RAISED - VISIBLE"); + DECLARE + Z : SUB_ACC := NEW INCOMPLETE(IDENT_INT(6)); + BEGIN + IF IDENT_INT(Z.T) = IDENT_INT(6) THEN + COMMENT("THIS LINE SHOULD NOT PRINT"); + END IF; + END; + EXCEPTION + WHEN CONSTRAINT_ERROR => + FAILED("CONSTRAINT_ERROR RAISED LATE " & + "- VISIBLE"); + WHEN OTHERS => + FAILED("UNEXPECTED EXCEPTION RAISED " & + "LATE - VISIBLE"); + END PACK; + BEGIN + NULL; + END; + EXCEPTION + WHEN CONSTRAINT_ERROR => + NULL; + WHEN OTHERS => + FAILED("UNEXPECTED EXCEPTION RAISED " & + "- VISIBLE"); + END; + +------------------------------ PRIVATE ------------------------------ + BEGIN + DECLARE + PACKAGE PACK2 IS + SUBTYPE SMALLER IS INTEGER RANGE 1 .. 5; + + TYPE PRIV IS PRIVATE; + + PRIVATE + TYPE PRIV IS + RECORD + V : INTEGER; + END RECORD; + + TYPE INCOMPLETE(A : SMALLER); + + TYPE ACC_INC IS ACCESS INCOMPLETE; + SUBTYPE SUB_ACC IS ACC_INC(IDENT_INT(0)); + + TYPE INCOMPLETE(A : SMALLER) IS + RECORD + T : INTEGER := A; + U : PRIV := (V => A ** IDENT_INT(2)); + END RECORD; + + END PACK2; + + PACKAGE BODY PACK2 IS + BEGIN + FAILED("CONSTRAINT_ERROR NOT RAISED - PRIVATE"); + DECLARE + Z : SUB_ACC := NEW INCOMPLETE(IDENT_INT(0)); + BEGIN + IF IDENT_INT(Z.T) = IDENT_INT(0) THEN + COMMENT("THIS LINE SHOULD NOT PRINT"); + END IF; + END; + EXCEPTION + WHEN CONSTRAINT_ERROR => + FAILED("CONSTRAINT_ERROR RAISED TOO LATE " & + "- PRIVATE"); + WHEN OTHERS => + FAILED("UNEXPECTED EXCEPTION RAISED LATE" & + "- PRIVATE"); + END PACK2; + BEGIN + NULL; + END; + EXCEPTION + WHEN CONSTRAINT_ERROR => + NULL; + WHEN OTHERS => + FAILED("UNEXPECTED EXCEPTION RAISED " & + "- PRIVATE"); + END; + +-------------------------- DECLARATIVE PART -------------------------- + BEGIN + DECLARE + SUBTYPE SMALLER IS INTEGER RANGE 1 .. 5; + + TYPE INCOMPLETE(A : SMALLER); + + TYPE ACC_INC IS ACCESS INCOMPLETE; + SUBTYPE SUB_ACC IS ACC_INC(IDENT_INT(6)); + + TYPE INCOMPLETE(A : SMALLER) IS + RECORD + T : INTEGER := INTEGER'(A); + END RECORD; + + BEGIN + FAILED("CONSTRAINT_ERROR NOT RAISED - BLOCK " & + "STATEMENT"); + DECLARE + Z : SUB_ACC := NEW INCOMPLETE(IDENT_INT(6)); + BEGIN + IF IDENT_INT(Z.T) = IDENT_INT(6) THEN + COMMENT("THIS LINE SHOULD NOT PRINT"); + END IF; + END; + EXCEPTION + WHEN CONSTRAINT_ERROR => + FAILED("CONSTRAINT_ERROR RAISED TOO LATE " & + "- BLOCK STATEMENT"); + WHEN OTHERS => + FAILED("UNEXPECTED EXCEPTION RAISED LATE" & + "- BLOCK STATEMENT"); + END; + EXCEPTION + WHEN CONSTRAINT_ERROR => + NULL; + WHEN OTHERS => + FAILED("UNEXPECTED EXCEPTION RAISED " & + "- BLOCK STATEMENT"); + END; + + RESULT; +END C38107B; diff --git a/gcc-4.9/gcc/testsuite/ada/acats/tests/c3/c38108a.ada b/gcc-4.9/gcc/testsuite/ada/acats/tests/c3/c38108a.ada new file mode 100644 index 000000000..4e533b7d8 --- /dev/null +++ b/gcc-4.9/gcc/testsuite/ada/acats/tests/c3/c38108a.ada @@ -0,0 +1,77 @@ +-- C38108A.ADA + +-- Grant of Unlimited Rights +-- +-- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687, +-- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained +-- unlimited rights in the software and documentation contained herein. +-- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making +-- this public release, the Government intends to confer upon all +-- recipients unlimited rights equal to those held by the Government. +-- These rights include rights to use, duplicate, release or disclose the +-- released technical data and computer software in whole or in part, in +-- any manner and for any purpose whatsoever, and to have or permit others +-- to do so. +-- +-- DISCLAIMER +-- +-- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR +-- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED +-- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF 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 INCOMPLETE TYPE CAN BE DECLARED IN THE PRIVATE PART OF +-- A PACKAGE, WITH THE FULL DECLARATION OCCURRING IN THE PACKAGE BODY. + +-- AH 8/20/86 + +WITH REPORT; USE REPORT; +PROCEDURE C38108A IS + + PACKAGE P IS + TYPE L IS LIMITED PRIVATE; + PROCEDURE ASSIGN (X : IN INTEGER; Y : IN OUT L); + FUNCTION "=" (X, Y : IN L) RETURN BOOLEAN; + PRIVATE + TYPE INC (D : INTEGER); + TYPE L IS ACCESS INC; + END P; + + PACKAGE BODY P IS + TYPE INC (D : INTEGER) IS + RECORD + C : INTEGER; + END RECORD; + + PROCEDURE ASSIGN (X : IN INTEGER; Y : IN OUT L) IS + BEGIN + Y := NEW INC(1); + Y.C := X; + END ASSIGN; + + FUNCTION "=" (X, Y : IN L) RETURN BOOLEAN IS + BEGIN + RETURN (X.C = Y.C); + END "="; + + END P; + +USE P; +BEGIN + + TEST ("C38108A", "CHECK THAT INCOMPLETE TYPE CAN BE DECLARED IN " & + "PRIVATE PART WITHOUT FULL DECLARATION"); + DECLARE + VAL_1, VAL_2 : L; + BEGIN + ASSIGN (2, VAL_1); + ASSIGN (2, VAL_2); + IF NOT "=" (VAL_1, VAL_2) THEN + FAILED ("INCOMPLETE TYPE NOT FULLY DECLARED"); + END IF; + END; + + RESULT; +END C38108A; diff --git a/gcc-4.9/gcc/testsuite/ada/acats/tests/c3/c38108b.ada b/gcc-4.9/gcc/testsuite/ada/acats/tests/c3/c38108b.ada new file mode 100644 index 000000000..120e51a35 --- /dev/null +++ b/gcc-4.9/gcc/testsuite/ada/acats/tests/c3/c38108b.ada @@ -0,0 +1,76 @@ +-- C38108B.ADA + +-- Grant of Unlimited Rights +-- +-- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687, +-- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained +-- unlimited rights in the software and documentation contained herein. +-- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making +-- this public release, the Government intends to confer upon all +-- recipients unlimited rights equal to those held by the Government. +-- These rights include rights to use, duplicate, release or disclose the +-- released technical data and computer software in whole or in part, in +-- any manner and for any purpose whatsoever, and to have or permit others +-- to do so. +-- +-- DISCLAIMER +-- +-- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR +-- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED +-- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF 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 INCOMPLETE TYPE CAN BE DECLARED IN THE PRIVATE PART OF +-- A LIBRARY PACKAGE, WITH THE FULL DECLARATION OCCURRING LATER IN A +-- PACKAGE BODY. + +-- AH 8/20/86 + +PACKAGE C38108B_P IS + TYPE L IS LIMITED PRIVATE; + PROCEDURE ASSIGN (X : IN INTEGER; Y : IN OUT L); + FUNCTION "=" (X, Y : IN L) RETURN BOOLEAN; +PRIVATE + TYPE INC (D : INTEGER); + TYPE L IS ACCESS INC; +END C38108B_P; + +PACKAGE BODY C38108B_P IS + TYPE INC (D : INTEGER) IS + RECORD + C : INTEGER; + END RECORD; + + PROCEDURE ASSIGN (X : IN INTEGER; Y : IN OUT L) IS + BEGIN + Y := NEW INC(1); + Y.C := X; + END ASSIGN; + + FUNCTION "=" (X, Y : IN L) RETURN BOOLEAN IS + BEGIN + RETURN (X.C = Y.C); + END "="; + +END C38108B_P; + +WITH REPORT; USE REPORT; +WITH C38108B_P; USE C38108B_P; +PROCEDURE C38108B IS + VAL_1, VAL_2 : L; +BEGIN + + TEST ("C38108B", "CHECK THAT INCOMPLETE TYPE CAN BE DECLARED IN " & + "PRIVATE PART WITHOUT FULL DECLARATION - " & + "LIBRARY PACKAGE"); + + ASSIGN (2, VAL_1); + ASSIGN (2, VAL_2); + IF NOT "=" (VAL_1, VAL_2) THEN + FAILED ("INCOMPLETE TYPE NOT FULLY DECLARED"); + END IF; + + RESULT; +END C38108B; diff --git a/gcc-4.9/gcc/testsuite/ada/acats/tests/c3/c38108c0.ada b/gcc-4.9/gcc/testsuite/ada/acats/tests/c3/c38108c0.ada new file mode 100644 index 000000000..780436a68 --- /dev/null +++ b/gcc-4.9/gcc/testsuite/ada/acats/tests/c3/c38108c0.ada @@ -0,0 +1,36 @@ +-- C38108C0.ADA + +-- Grant of Unlimited Rights +-- +-- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687, +-- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained +-- unlimited rights in the software and documentation contained herein. +-- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making +-- this public release, the Government intends to confer upon all +-- recipients unlimited rights equal to those held by the Government. +-- These rights include rights to use, duplicate, release or disclose the +-- released technical data and computer software in whole or in part, in +-- any manner and for any purpose whatsoever, and to have or permit others +-- to do so. +-- +-- DISCLAIMER +-- +-- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR +-- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED +-- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE +-- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE +-- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A +-- PARTICULAR PURPOSE OF SAID MATERIAL. +--* +-- SPECIFICATION OF LIBRARY PACKAGE USED WITH C38108C1M. + +-- AH 8/20/86 + +PACKAGE C38108C0 IS + TYPE L IS LIMITED PRIVATE; + PROCEDURE ASSIGN (X : IN INTEGER; Y : IN OUT L); + FUNCTION "=" (X, Y : IN L) RETURN BOOLEAN; +PRIVATE + TYPE INC (D : INTEGER); + TYPE L IS ACCESS INC; +END C38108C0; diff --git a/gcc-4.9/gcc/testsuite/ada/acats/tests/c3/c38108c1.ada b/gcc-4.9/gcc/testsuite/ada/acats/tests/c3/c38108c1.ada new file mode 100644 index 000000000..523663fcc --- /dev/null +++ b/gcc-4.9/gcc/testsuite/ada/acats/tests/c3/c38108c1.ada @@ -0,0 +1,52 @@ +-- C38108C1M.ADA + +-- Grant of Unlimited Rights +-- +-- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687, +-- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained +-- unlimited rights in the software and documentation contained herein. +-- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making +-- this public release, the Government intends to confer upon all +-- recipients unlimited rights equal to those held by the Government. +-- These rights include rights to use, duplicate, release or disclose the +-- released technical data and computer software in whole or in part, in +-- any manner and for any purpose whatsoever, and to have or permit others +-- to do so. +-- +-- DISCLAIMER +-- +-- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR +-- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED +-- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF 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 INCOMPLETE TYPE CAN BE DELCARED IN A SEPARATELY +-- COMPILED PACKAGE SPECIFICATION AND ITS FULL DECLARATION CAN LATER BE +-- GIVEN IN A SEPARATELY COMPILED BODY. + +-- AH 8/20/86 + +-- C38108C0 THE PACKAGE SPECIFICATION. +-- C38108C1M THE MAIN PROGRAM. +-- C38108C2 THE PACKAGE BODY. + +WITH REPORT; USE REPORT; +WITH C38108C0; USE C38108C0; +PROCEDURE C38108C1M IS + VAL_1, VAL_2 : L; +BEGIN + + TEST ("C38108C", "CHECK THAT INCOMPLETE TYPE CAN BE DECLARED IN " & + "PRIVATE PART WITHOUT FULL DECLARATION - " & + "LIBRARY PACKAGE"); + + ASSIGN (2, VAL_1); + ASSIGN (2, VAL_2); + IF NOT "=" (VAL_1, VAL_2) THEN + FAILED ("INCOMPLETE TYPE NOT FULLY DECLARED"); + END IF; + + RESULT; +END C38108C1M; diff --git a/gcc-4.9/gcc/testsuite/ada/acats/tests/c3/c38108c2.ada b/gcc-4.9/gcc/testsuite/ada/acats/tests/c3/c38108c2.ada new file mode 100644 index 000000000..9dda7aac0 --- /dev/null +++ b/gcc-4.9/gcc/testsuite/ada/acats/tests/c3/c38108c2.ada @@ -0,0 +1,47 @@ +-- C38108C2.ADA + +-- Grant of Unlimited Rights +-- +-- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687, +-- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained +-- unlimited rights in the software and documentation contained herein. +-- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making +-- this public release, the Government intends to confer upon all +-- recipients unlimited rights equal to those held by the Government. +-- These rights include rights to use, duplicate, release or disclose the +-- released technical data and computer software in whole or in part, in +-- any manner and for any purpose whatsoever, and to have or permit others +-- to do so. +-- +-- DISCLAIMER +-- +-- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR +-- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED +-- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE +-- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE +-- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A +-- PARTICULAR PURPOSE OF SAID MATERIAL. +--* +-- PACKAGE BODY FOR USE WITH C38108C1M. +-- SPECIFICATION IS IN C38108C0. + +-- AH 8/20/86 + +PACKAGE BODY C38108C0 IS + TYPE INC (D : INTEGER) IS + RECORD + C : INTEGER; + END RECORD; + + PROCEDURE ASSIGN (X : IN INTEGER; Y : IN OUT L) IS + BEGIN + Y := NEW INC(1); + Y.C := X; + END ASSIGN; + + FUNCTION "=" (X, Y : IN L) RETURN BOOLEAN IS + BEGIN + RETURN (X.C = Y.C); + END "="; + +END C38108C0; diff --git a/gcc-4.9/gcc/testsuite/ada/acats/tests/c3/c38108d0.ada b/gcc-4.9/gcc/testsuite/ada/acats/tests/c3/c38108d0.ada new file mode 100644 index 000000000..4b24e7c59 --- /dev/null +++ b/gcc-4.9/gcc/testsuite/ada/acats/tests/c3/c38108d0.ada @@ -0,0 +1,65 @@ +-- C38108D0M.ADA + +-- Grant of Unlimited Rights +-- +-- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687, +-- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained +-- unlimited rights in the software and documentation contained herein. +-- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making +-- this public release, the Government intends to confer upon all +-- recipients unlimited rights equal to those held by the Government. +-- These rights include rights to use, duplicate, release or disclose the +-- released technical data and computer software in whole or in part, in +-- any manner and for any purpose whatsoever, and to have or permit others +-- to do so. +-- +-- DISCLAIMER +-- +-- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR +-- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED +-- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF 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 INCOMPLETE TYPE CAN BE DECLARED IN THE PRIVATE PART OF +-- A PACKAGE, WITH THE FULL DECLARATION OCCURRING LATER IN A +-- PACKAGE BODY SUBUNIT. + +-- OTHER FILES: C38108D1.ADA (PACKAGE BODY SUBUNIT.) + +-- AH 8/20/86 + +WITH REPORT; USE REPORT; + +PROCEDURE C38108D0M IS + PACKAGE C38108D1 IS + TYPE L IS LIMITED PRIVATE; + PROCEDURE ASSIGN (X : IN INTEGER; Y : IN OUT L); + FUNCTION "=" (X, Y : IN L) RETURN BOOLEAN; + PRIVATE + TYPE INC (D : INTEGER); + TYPE L IS ACCESS INC; + END C38108D1; + + PACKAGE BODY C38108D1 IS SEPARATE; + +USE C38108D1; +BEGIN + + TEST ("C38108D", "CHECK THAT INCOMPLETE TYPE CAN BE DECLARED IN " & + "PRIVATE PART WITH FULL DECLARATION IN " & + "A PACKAGE BODY SUBUNIT"); + +DECLARE + VAL_1, VAL_2 : L; +BEGIN + ASSIGN (2, VAL_1); + ASSIGN (2, VAL_2); + IF NOT "=" (VAL_1, VAL_2) THEN + FAILED ("INCOMPLETE TYPE NOT FULLY DECLARED"); + END IF; +END; + + RESULT; +END C38108D0M; diff --git a/gcc-4.9/gcc/testsuite/ada/acats/tests/c3/c38108d1.ada b/gcc-4.9/gcc/testsuite/ada/acats/tests/c3/c38108d1.ada new file mode 100644 index 000000000..895e956a8 --- /dev/null +++ b/gcc-4.9/gcc/testsuite/ada/acats/tests/c3/c38108d1.ada @@ -0,0 +1,47 @@ +-- C38108D1.ADA + +-- Grant of Unlimited Rights +-- +-- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687, +-- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained +-- unlimited rights in the software and documentation contained herein. +-- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making +-- this public release, the Government intends to confer upon all +-- recipients unlimited rights equal to those held by the Government. +-- These rights include rights to use, duplicate, release or disclose the +-- released technical data and computer software in whole or in part, in +-- any manner and for any purpose whatsoever, and to have or permit others +-- to do so. +-- +-- DISCLAIMER +-- +-- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR +-- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED +-- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE +-- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE +-- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A +-- PARTICULAR PURPOSE OF SAID MATERIAL. +--* +-- PACKAGE BODY SUBUNIT USED WITH C38108D0M. + +-- AH 8/20/86 + +SEPARATE (C38108D0M) +PACKAGE BODY C38108D1 IS + TYPE INC (D : INTEGER) IS + RECORD + C : INTEGER; + END RECORD; + + PROCEDURE ASSIGN (X : IN INTEGER; Y : IN OUT L) IS + BEGIN + Y := NEW INC(1); + Y.C := X; + END ASSIGN; + + FUNCTION "=" (X, Y : IN L) RETURN BOOLEAN IS + BEGIN + RETURN (X.C = Y.C); + END "="; + +END C38108D1; diff --git a/gcc-4.9/gcc/testsuite/ada/acats/tests/c3/c38202a.ada b/gcc-4.9/gcc/testsuite/ada/acats/tests/c3/c38202a.ada new file mode 100644 index 000000000..d0350fc1f --- /dev/null +++ b/gcc-4.9/gcc/testsuite/ada/acats/tests/c3/c38202a.ada @@ -0,0 +1,197 @@ +-- C38202A.ADA + +-- Grant of Unlimited Rights +-- +-- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687, +-- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained +-- unlimited rights in the software and documentation contained herein. +-- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making +-- this public release, the Government intends to confer upon all +-- recipients unlimited rights equal to those held by the Government. +-- These rights include rights to use, duplicate, release or disclose the +-- released technical data and computer software in whole or in part, in +-- any manner and for any purpose whatsoever, and to have or permit others +-- to do so. +-- +-- DISCLAIMER +-- +-- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR +-- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED +-- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF 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 TASKING ATTRIBUTES ARE DECLARED AND RETURN CORRECT +-- VALUES FOR OBJECTS HAVING AN ACCESS TYPE WHOSE DESIGNATED +-- TYPE IS A TASK TYPE. +-- CHECK THE ACCESS TYPE RESULTS OF FUNCTION CALLS. + +-- AH 9/12/86 +-- EDS 7/14/98 AVOID OPTIMIZATION + +with Impdef; +WITH REPORT; USE REPORT; +PROCEDURE C38202A IS +BEGIN + TEST ("C38202A", "OBJECTS HAVING ACCESS TYPES WITH DESIGNATED " & + "TASK TYPE CAN BE PREFIX OF TASKING ATTRIBUTES"); + +-- CHECK TWO CASES: (1) TASK IS CALLABLE, NOT TERMINATED. +-- (2) TASK IS NOT CALLABLE, TERMINATED. + + DECLARE + TASK TYPE TSK IS + ENTRY GO_ON; + END TSK; + + TASK DRIVER IS + ENTRY TSK_DONE; + END DRIVER; + + TYPE P_TYPE IS ACCESS TSK; + P : P_TYPE; + + TASK BODY TSK IS + I : INTEGER RANGE 0 .. 2; + BEGIN + ACCEPT GO_ON; + I := IDENT_INT(5); -- CONSTRAINT_ERROR RAISED. + FAILED ("CONSTAINT_ERROR NOT RAISED IN TASK " & + " TSK - 1A " & INTEGER'IMAGE(I)); + EXCEPTION + WHEN CONSTRAINT_ERROR => + DRIVER.TSK_DONE; + WHEN OTHERS => + FAILED ("WRONG EXCEPTION RAISED IN TASK " & + "TSK - 1A "); + DRIVER.TSK_DONE; + END TSK; + + TASK BODY DRIVER IS + COUNTER : INTEGER := 1; + BEGIN + P := NEW TSK; + IF NOT P'CALLABLE THEN + FAILED ("TASKING ATTRIBUTE RETURNS INCORRECT " & + "VALUE - 1B"); + END IF; + + IF P'TERMINATED THEN + FAILED ("TASKING ATTRIBUTE RETURNS INCORRECT " & + "VALUE - 1C"); + END IF; + + P.GO_ON; + ACCEPT TSK_DONE; + WHILE (NOT P'TERMINATED AND COUNTER <= 3) LOOP + DELAY 10.0 * Impdef.One_Second; + COUNTER := COUNTER + 1; + END LOOP; + + IF COUNTER > 3 THEN + FAILED ("TASK TSK NOT TERMINATED IN SUFFICIENT " & + "TIME - 1D"); + END IF; + + IF P'CALLABLE THEN + FAILED ("TASKING ATTRIBUTE RETURNS INCORRECT " & + "VALUE - 1E"); + END IF; + + IF NOT P'TERMINATED THEN + FAILED ("TASKING ATTRIBUTE RETURNS INCORRECT " & + "VALUE - 1F"); + END IF; + END DRIVER; + + BEGIN + NULL; + END; -- BLOCK + +-- CHECK ACCESS TYPE RESULT RETURNED FROM FUNCTION. +-- CHECK TWO CASES: (1) TASK IS CALLABLE, NOT TERMINATED. +-- (2) TASK IS NOT CALLABLE, TERMINATED. + + DECLARE + TASK TYPE TSK IS + ENTRY GO_ON; + END TSK; + + TASK DRIVER IS + ENTRY TSK_DONE; + END DRIVER; + + TYPE P_TYPE IS ACCESS TSK; + P : P_TYPE; + + TSK_CREATED : BOOLEAN := FALSE; + + FUNCTION F1 RETURN P_TYPE IS + BEGIN + RETURN P; + END F1; + + TASK BODY TSK IS + I : INTEGER RANGE 0 .. 2; + BEGIN + ACCEPT GO_ON; + I := IDENT_INT(5); -- CONSTRAINT_ERROR RAISED. + FAILED ("CONSTRAINT_ERROR NOT RAISED IN TASK " & + "TSK - 2A " & INTEGER'IMAGE(I)); + EXCEPTION + WHEN CONSTRAINT_ERROR => + DRIVER.TSK_DONE; + WHEN OTHERS => + FAILED ("WRONG EXCEPTION RAISED IN TASK " & + "TSK - 2A "); + DRIVER.TSK_DONE; + END TSK; + + TASK BODY DRIVER IS + COUNTER : INTEGER := 1; + BEGIN + P := NEW TSK; -- ACTIVATE P.ALL (F1.ALL). + IF NOT F1'CALLABLE THEN + FAILED ("TASKING ATTRIBUTE RETURNS INCORRECT " & + "VALUE WHEN PREFIX IS VALUE FROM " & + "FUNCTION CALL - 2B"); + END IF; + + IF F1'TERMINATED THEN + FAILED ("TASKING ATTRIBUTE RETURNS INCORRECT " & + "VALUE WHEN PREFIX IS VALUE FROM " & + "FUNCTION CALL - 2C"); + END IF; + + F1.ALL.GO_ON; + ACCEPT TSK_DONE; + WHILE (NOT F1'TERMINATED AND COUNTER <= 3) LOOP + DELAY 10.0 * Impdef.One_Second; + COUNTER := COUNTER + 1; + END LOOP; + + IF COUNTER > 3 THEN + FAILED ("TASK TSK NOT TERMINATED IN SUFFICIENT " & + "TIME - 2D"); + END IF; + + IF F1'CALLABLE THEN + FAILED ("TASKING ATTRIBUTE RETURNS INCORRECT " & + "VALUE WHEN PREFIX IS VALUE FROM " & + "FUNCTION CALL - 2E"); + END IF; + + IF NOT F1'TERMINATED THEN + FAILED ("TASKING ATTRIBUTE RETURNS INCORRECT " & + "VALUE WHEN PREFIX IS VALUE FROM " & + "FUNCTION CALL - 2F"); + END IF; + END DRIVER; + + BEGIN + NULL; + END; -- BLOCK + + RESULT; +END C38202A; diff --git a/gcc-4.9/gcc/testsuite/ada/acats/tests/c3/c3900010.a b/gcc-4.9/gcc/testsuite/ada/acats/tests/c3/c3900010.a new file mode 100644 index 000000000..6d9ddb4a1 --- /dev/null +++ b/gcc-4.9/gcc/testsuite/ada/acats/tests/c3/c3900010.a @@ -0,0 +1,147 @@ +-- C3900010.A +-- +-- Grant of Unlimited Rights +-- +-- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687, +-- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained +-- unlimited rights in the software and documentation contained herein. +-- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making +-- this public release, the Government intends to confer upon all +-- recipients unlimited rights equal to those held by the Government. +-- These rights include rights to use, duplicate, release or disclose the +-- released technical data and computer software in whole or in part, in +-- any manner and for any purpose whatsoever, and to have or permit others +-- to do so. +-- +-- DISCLAIMER +-- +-- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR +-- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED +-- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE +-- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE +-- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A +-- PARTICULAR PURPOSE OF SAID MATERIAL. +--* +-- +-- OBJECTIVE: +-- See C3900011.AM. +-- +-- TEST DESCRIPTION: +-- See C3900011.AM. +-- +-- TEST FILES: +-- This test consists of the following files: +-- +-- => C3900010.A +-- C3900011.AM +-- +-- CHANGE HISTORY: +-- 06 Dec 94 SAIC ACVC 2.0 +-- 15 May 96 SAIC ACVC 2.1: Modified prologue. Added pragma Elaborate +-- for Ada.Calendar. +-- +--! + +with Ada.Calendar; +pragma Elaborate (Ada.Calendar); + +package C3900010 is + + + -- Declarations used by component Display_On and procedure Display. + + type Device_Enum is (Null_Device, Teletype, Console, Big_Screen); + type Display_Counters is array (Device_Enum) of Natural; + + Display_Count_For : Display_Counters := (others => 0); + + + -- Declarations required for component Arrival_Time. + + Default_Time : constant Ada.Calendar.Time := + Ada.Calendar.Time_Of (1901, 1, 1); + Alert_Time : constant Ada.Calendar.Time := + Ada.Calendar.Time_Of (1991, 6, 15); + + + type Alert_Type is tagged record -- Root tagged type. + Arrival_Time : Ada.Calendar.Time := Default_Time; + Display_On : Device_Enum := Null_Device; + end record; + + + procedure Display (A : in Alert_Type); -- To be inherited by + -- all derivatives. + + procedure Handle (A : in out Alert_Type); -- To be inherited by + -- all derivatives. + + + + type Low_Alert_Type is new Alert_Type with record -- Record extension of + Level : Integer := 0; -- root tagged type. + end record; + + -- Inherits procedure Display from Alert. + -- Inherits procedure Handle from Alert. + + function Level_Of (LA : in Low_Alert_Type) -- To be inherited by + return Integer; -- all derivatives. + + + + -- Declarations required for component Action_Officer; + + type Person_Enum is (Nobody, Duty_Officer, + Watch_Commander, Commanding_Officer); + + + + type Medium_Alert_Type is new Low_Alert_Type with record + Action_Officer : Person_Enum := Nobody; -- Record extension of + end record; -- record extension. + + -- Inherits (inherited) procedure Display from Low_Alert_Type. + -- Inherits (inherited) procedure Handle from Low_Alert_Type. + + -- Inherits function Level_Of from Low_Alert_Type. + + procedure Assign_Officer (MA : in out Medium_Alert_Type; + To : in Person_Enum); + + +end C3900010; + + + --==================================================================-- + + +package body C3900010 is + + + procedure Display (A : in Alert_Type) is + begin + Display_Count_For (A.Display_On) := Display_Count_For (A.Display_On) + 1; + end Display; + + + procedure Handle (A : in out Alert_Type) is + begin + A.Arrival_Time := Alert_Time; + end Handle; + + + function Level_Of (LA : in Low_Alert_Type) return Integer is + begin + return (LA.Level + 1); + end Level_Of; + + + procedure Assign_Officer (MA : in out Medium_Alert_Type; + To : in Person_Enum) is + begin + MA.Action_Officer := To; + end Assign_Officer; + + +end C3900010; diff --git a/gcc-4.9/gcc/testsuite/ada/acats/tests/c3/c3900011.am b/gcc-4.9/gcc/testsuite/ada/acats/tests/c3/c3900011.am new file mode 100644 index 000000000..68207f32a --- /dev/null +++ b/gcc-4.9/gcc/testsuite/ada/acats/tests/c3/c3900011.am @@ -0,0 +1,253 @@ +-- C3900011.AM +-- +-- Grant of Unlimited Rights +-- +-- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687, +-- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained +-- unlimited rights in the software and documentation contained herein. +-- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making +-- this public release, the Government intends to confer upon all +-- recipients unlimited rights equal to those held by the Government. +-- These rights include rights to use, duplicate, release or disclose the +-- released technical data and computer software in whole or in part, in +-- any manner and for any purpose whatsoever, and to have or permit others +-- to do so. +-- +-- DISCLAIMER +-- +-- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR +-- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED +-- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE +-- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE +-- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A +-- PARTICULAR PURPOSE OF SAID MATERIAL. +--* +-- +-- OBJECTIVE: +-- Check that a record extension can be declared in the same package +-- as its parent, and that this parent may be a tagged record or a +-- record extension. Check that each derivative inherits all user- +-- defined primitive subprograms of its parent (including those that +-- its parent inherited), and that it may declare its own primitive +-- subprograms. +-- +-- Check that predefined equality operators are defined for the root +-- tagged type. +-- +-- Check that type conversion is defined from a type extension to its +-- parent, and that this parent itself may be a type extension. +-- +-- TEST DESCRIPTION: +-- Declare a root tagged type in a package specification. Declare two +-- primitive subprograms for the type. +-- +-- Extend the root type with a record extension in the same package +-- specification. Declare a new primitive subprogram for the extension +-- (in addition to its two inherited subprograms). +-- +-- Extend the extension with a record extension in the same package +-- specification. Declare a new primitive subprogram for this second +-- extension (in addition to its three inherited subprograms). +-- +-- In the main program, declare operations for the root tagged type which +-- utilize aggregates and equality operators to verify the correctness +-- of the components. Overload these operations for the two type +-- extensions. Within each of these overloading operations, utilize type +-- conversion to call the parent's implementation of the same operation. +-- +-- TEST FILES: +-- The following files comprise this test: +-- +-- C3900010.A +-- => C3900011.AM +-- +-- +-- CHANGE HISTORY: +-- 06 Dec 94 SAIC ACVC 2.0 +-- +--! + +with C3900010; +with Report; +procedure C3900011 is + + + package Check_Alert_Values is + + -- Declare functions to verify correctness of tagged record components + -- before and after calls to their primitive subprograms. + + + -- Alert_Type: + + function Initial_Values_Okay (A : in C3900010.Alert_Type) + return Boolean; + + function Bad_Final_Values (A : in C3900010.Alert_Type) + return Boolean; + + + -- Low_Alert_Type: + + function Initial_Values_Okay (LA : in C3900010.Low_Alert_Type) + return Boolean; + + function Bad_Final_Values (LA : in C3900010.Low_Alert_Type) + return Boolean; + + + -- Medium_Alert_Type: + + function Initial_Values_Okay (MA : in C3900010.Medium_Alert_Type) + return Boolean; + + function Bad_Final_Values (MA : in C3900010.Medium_Alert_Type) + return Boolean; + + + end Check_Alert_Values; + + + --==========================================================-- + + + package body Check_Alert_Values is + + + function Initial_Values_Okay (A : in C3900010.Alert_Type) + return Boolean is + use type C3900010.Alert_Type; + begin -- "=" operator availability. + return (A = (Arrival_Time => C3900010.Default_Time, + Display_On => C3900010.Null_Device)); + end Initial_Values_Okay; + + + function Initial_Values_Okay (LA : in C3900010.Low_Alert_Type) + return Boolean is + begin -- Type conversion. + return (Initial_Values_Okay (C3900010.Alert_Type (LA)) and + LA.Level = 0); + end Initial_Values_Okay; + + + function Initial_Values_Okay (MA : in C3900010.Medium_Alert_Type) + return Boolean is + use type C3900010.Person_Enum; + begin -- Type conversion. + return (Initial_Values_Okay (C3900010.Low_Alert_Type (MA)) and + MA.Action_Officer = C3900010.Nobody); + end Initial_Values_Okay; + + + function Bad_Final_Values (A : in C3900010.Alert_Type) + return Boolean is + use type C3900010.Alert_Type; + begin -- "/=" operator availability. + return (A /= (Arrival_Time => C3900010.Alert_Time, + Display_On => C3900010.Null_Device)); + end Bad_Final_Values; + + + function Bad_Final_Values (LA : in C3900010.Low_Alert_Type) + return Boolean is + use type C3900010.Low_Alert_Type; + begin -- "=" operator availability. + return not ( LA = (Arrival_Time => C3900010.Alert_Time, + Display_On => C3900010.Teletype, + Level => 1) ); + end Bad_Final_Values; + + + function Bad_Final_Values (MA : in C3900010.Medium_Alert_Type) + return Boolean is + use type C3900010.Medium_Alert_Type; + begin -- "/=" operator availability. + return ( MA /= (C3900010.Alert_Time, + C3900010.Console, + 1, + C3900010.Duty_Officer) ); + end Bad_Final_Values; + + + end Check_Alert_Values; + + + --==========================================================-- + + + use Check_Alert_Values; + use C3900010; + + Root_Alarm : C3900010.Alert_Type; + Low_Alarm : C3900010.Low_Alert_Type; + Medium_Alarm : C3900010.Medium_Alert_Type; + +begin + + Report.Test ("C390001", "Primitive operation inheritance by type " & + "extensions: all extensions declared in same package " & + "as parent"); + + +-- Check root tagged type: + + if Initial_Values_Okay (Root_Alarm) then + Handle (Root_Alarm); -- Explicitly declared. + Display (Root_Alarm); -- Explicitly declared. + + if Bad_Final_Values (Root_Alarm) then + Report.Failed ("Wrong results after Alert_Type calls"); + end if; + else + Report.Failed ("Wrong initial values for Alert_Type"); + end if; + + +-- Check record extension of root tagged type: + + if Initial_Values_Okay (Low_Alarm) then + Handle (Low_Alarm); -- Inherited. + Low_Alarm.Display_On := Teletype; + Display (Low_Alarm); -- Inherited. + Low_Alarm.Level := Level_Of (Low_Alarm); -- Explicitly declared. + + if Bad_Final_Values (Low_Alarm) then + Report.Failed ("Wrong results after Low_Alert_Type calls"); + end if; + else + Report.Failed ("Wrong initial values for Low_Alert_Type"); + end if; + + +-- Check record extension of record extension: + + if Initial_Values_Okay (Medium_Alarm) then + Handle (Medium_Alarm); -- Inherited twice. + Medium_Alarm.Display_On := Console; + Display (Medium_Alarm); -- Inherited twice. + Medium_Alarm.Level := Level_Of (Medium_Alarm); -- Inherited. + Assign_Officer (Medium_Alarm, Duty_Officer); -- Explicitly declared. + + if Bad_Final_Values (Medium_Alarm) then + Report.Failed ("Wrong results after Medium_Alert_Type calls"); + end if; + else + Report.Failed ("Wrong initial values for Medium_Alert_Type"); + end if; + + +-- Check final display counts: + + if C3900010.Display_Count_For /= (Null_Device => 1, + Teletype => 1, + Console => 1, + Big_Screen => 0) + then + Report.Failed ("Wrong final values for display counts"); + end if; + + + Report.Result; + +end C3900011; diff --git a/gcc-4.9/gcc/testsuite/ada/acats/tests/c3/c390002.a b/gcc-4.9/gcc/testsuite/ada/acats/tests/c3/c390002.a new file mode 100644 index 000000000..b3d11afed --- /dev/null +++ b/gcc-4.9/gcc/testsuite/ada/acats/tests/c3/c390002.a @@ -0,0 +1,165 @@ +-- C390002.A +-- +-- Grant of Unlimited Rights +-- +-- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687, +-- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained +-- unlimited rights in the software and documentation contained herein. +-- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making +-- this public release, the Government intends to confer upon all +-- recipients unlimited rights equal to those held by the Government. +-- These rights include rights to use, duplicate, release or disclose the +-- released technical data and computer software in whole or in part, in +-- any manner and for any purpose whatsoever, and to have or permit others +-- to do so. +-- +-- DISCLAIMER +-- +-- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR +-- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED +-- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE +-- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE +-- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A +-- PARTICULAR PURPOSE OF SAID MATERIAL. +--* +-- +-- OBJECTIVE: +-- Check that a tagged base type may be declared, and derived +-- from in simple, private and extended forms. (Overlaps with C390B04) +-- Check that the package Ada.Tags is present and correctly implemented. +-- Check for the correct operation of Expanded_Name, External_Tag and +-- Internal_Tag within that package. Check that the exception Tag_Error +-- is correctly raised on calling Internal_Tag with bad input. +-- +-- TEST DESCRIPTION: +-- This test declares a tagged type, and derives three types from it. +-- These types are then used to test the presence and function of the +-- package Ada.Tags. +-- +-- +-- CHANGE HISTORY: +-- 06 Dec 94 SAIC ACVC 2.0 +-- 19 Dec 94 SAIC Removed RM references from objective text. +-- 27 Jan 96 SAIC Update RM references for 2.1 +-- +--! + +with Report; +with Ada.Tags; + +procedure C390002 is + + package Vehicle is + + type Object is tagged limited private; -- ancestor type + procedure Create( The_Vehicle : in out Object; Wheels : in Natural ); + function Wheels( The_Vehicle : Object ) return Natural; + + private + + type Object is tagged limited record + Wheel_Count : Natural := 0; + end record; + + end Vehicle; + + package Motivators is + + type Bicycle is new Vehicle.Object with null record; -- simple + + type Car is new Vehicle.Object with record -- extended + Convertible : Boolean; + end record; + + type Truck is new Vehicle.Object with private; -- private + + private + + type Truck is new Vehicle.Object with record + Air_Horn : Boolean; + end record; + + end Motivators; + + package body Vehicle is + + procedure Create( The_Vehicle : in out Object; Wheels : in Natural ) is + begin + The_Vehicle.Wheel_Count := Wheels; + end Create; + + function Wheels( The_Vehicle : Object ) return Natural is + begin + return The_Vehicle.Wheel_Count; + end Wheels; + + end Vehicle; + + function TC_ID_Tag( Tag : in Ada.Tags.Tag ) return Ada.Tags.Tag is + begin + return Ada.Tags.Internal_Tag( Ada.Tags.External_Tag( Tag ) ); + Report.Comment("This message intentionally blank."); + end TC_ID_Tag; + + procedure Check_Tags( Machine : in Vehicle.Object'Class; + Expected_Name : in String; + External_Tag : in String ) is + The_Tag : constant Ada.Tags.Tag := Machine'Tag; + use type Ada.Tags.Tag; + begin + if Ada.Tags.Expanded_Name(The_Tag) /= Expected_Name then + Report.Failed ("Failed in Check_Tags, Expanded_Name " + & Expected_Name); + end if; + if Ada.Tags.External_Tag(The_Tag) /= External_Tag then + Report.Failed ("Failed in Check_Tags, External_Tag " + & Expected_Name); + end if; + if Ada.Tags.Internal_Tag(External_Tag) /= The_Tag then + Report.Failed ("Failed in Check_Tags, Internal_Tag " + & Expected_Name); + end if; + end Check_Tags; + + procedure Check_Exception is + Boeing_777_Id : Ada.Tags.Tag; + begin + Boeing_777_Id := Ada.Tags.Internal_Tag("!@#$%^:*\/?"" not a tag!"); + Report.Failed ("Failed in Check_Exception, no exception"); + Boeing_777_Id := TC_ID_Tag( Boeing_777_Id ); + exception + when Ada.Tags.Tag_Error => null; + when others => + Report.Failed ("Failed in Check_Exception, wrong exception"); + end Check_Exception; + + use Motivators; + Two_Wheeler : Bicycle; + Four_Wheeler : Car; + Eighteen_Wheeler : Truck; + +begin -- Main test procedure. + + Report.Test ("C390002", "Check that a tagged type may be declared and " & + "derived from in simple, private and extended forms. " & + "Check package Ada.Tags" ); + + Create( Two_Wheeler, 2 ); + Create( Four_Wheeler, 4 ); + Create( Eighteen_Wheeler, 18 ); + + Check_Tags( Machine => Two_Wheeler, + Expected_Name => "C390002.MOTIVATORS.BICYCLE", + External_Tag => Bicycle'External_Tag ); + Check_Tags( Machine => Four_Wheeler, + Expected_Name => "C390002.MOTIVATORS.CAR", + External_Tag => Car'External_Tag ); + Check_Tags( Machine => Eighteen_Wheeler, + Expected_Name => "C390002.MOTIVATORS.TRUCK", + External_Tag => Truck'External_Tag ); + + Check_Exception; + + Report.Result; + +end C390002; diff --git a/gcc-4.9/gcc/testsuite/ada/acats/tests/c3/c390003.a b/gcc-4.9/gcc/testsuite/ada/acats/tests/c3/c390003.a new file mode 100644 index 000000000..643aad1cd --- /dev/null +++ b/gcc-4.9/gcc/testsuite/ada/acats/tests/c3/c390003.a @@ -0,0 +1,419 @@ +-- C390003.A +-- +-- Grant of Unlimited Rights +-- +-- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687, +-- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained +-- unlimited rights in the software and documentation contained herein. +-- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making +-- this public release, the Government intends to confer upon all +-- recipients unlimited rights equal to those held by the Government. +-- These rights include rights to use, duplicate, release or disclose the +-- released technical data and computer software in whole or in part, in +-- any manner and for any purpose whatsoever, and to have or permit others +-- to do so. +-- +-- DISCLAIMER +-- +-- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR +-- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED +-- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE +-- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE +-- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A +-- PARTICULAR PURPOSE OF SAID MATERIAL. +--* +-- +-- OBJECTIVE: +-- Check that for a subtype S of a tagged type T, S'Class denotes a +-- class-wide subtype. Check that T'Tag denotes the tag of the type T, +-- and that, for a class-wide tagged type X, X'Tag denotes the tag of X. +-- Check that the tags of stand alone objects, record and array +-- components, aggregates, and formal parameters identify their type. +-- Check that the tag of a value of a formal parameter is that of the +-- actual parameter, even if the actual is passed by a view conversion. +-- +-- TEST DESCRIPTION: +-- This test defines a class hierarchy (based on C390002) and +-- uses it to determine the correctness of the resulting tag +-- information generated by the compiler. A type is defined in the +-- class which contains components of the class as part of its +-- definition. This is to reduce the overall number of types +-- required, and to achieve the required nesting to accomplish +-- this test. The model is that of a car carrier truck; both car +-- and truck being in the class of Vehicle. +-- +-- Class Hierarchy: +-- Vehicle - - - - - - - (Bicycle) +-- / | \ / \ +-- Truck Car Q_Machine Tandem Motorcycle +-- | +-- Auto_Carrier +-- Contains: +-- Auto_Carrier( Car ) +-- Q_Machine( Car, Motorcycle ) +-- +-- +-- +-- CHANGE HISTORY: +-- 06 Dec 94 SAIC ACVC 2.0 +-- 19 Dec 94 SAIC Removed ARM references from objective text. +-- 20 Dec 94 SAIC Replaced three unnecessary extension +-- aggregates with simple aggregates. +-- 16 Oct 95 SAIC Fixed bugs for ACVC 2.0.1 +-- +--! + +----------------------------------------------------------------- C390003_1 + +with Ada.Tags; +package C390003_1 is -- Vehicle + + type TC_Keys is (Veh, MC, Tand, Car, Q, Truk, Heavy); + type States is (Good, Flat, Worn); + + type Wheel_List is array(Positive range <>) of States; + + type Object(Wheels: Positive) is tagged record + Wheel_State : Wheel_List(1..Wheels); + end record; + + procedure TC_Validate( It: Object; Key: TC_Keys ); + procedure TC_Validate( It: Object'Class; The_Tag: Ada.Tags.Tag ); + + procedure Create( The_Vehicle : in out Object; Tyres : in States ); + procedure Rotate( The_Vehicle : in out Object ); + function Wheels( The_Vehicle : Object ) return Positive; + +end C390003_1; -- Vehicle; + +----------------------------------------------------------------- C390003_2 + +with C390003_1; +package C390003_2 is -- Motivators + + package Vehicle renames C390003_1; + subtype Bicycle is Vehicle.Object(2); -- constrained subtype + + type Motorcycle is new Bicycle with record + Displacement : Natural; + end record; + procedure TC_Validate( It: Motorcycle; Key: Vehicle.TC_Keys ); + + type Tandem is new Bicycle with null record; + procedure TC_Validate( It: Tandem; Key: Vehicle.TC_Keys ); + + type Car is new Vehicle.Object(4) with -- extended, constrained + record + Displacement : Natural; + end record; + procedure TC_Validate( It: Car; Key: Vehicle.TC_Keys ); + + type Truck is new Vehicle.Object with -- extended, unconstrained + record + Tare : Natural; + end record; + procedure TC_Validate( It: Truck; Key: Vehicle.TC_Keys ); + +end C390003_2; -- Motivators; + +----------------------------------------------------------------- C390003_3 + +with C390003_1; +with C390003_2; +package C390003_3 is -- Special_Trucks + package Vehicle renames C390003_1; + package Motivators renames C390003_2; + Max_Cars_On_Vehicle : constant := 6; + type Cargo_Index is range 0..Max_Cars_On_Vehicle; + type Cargo is array(Cargo_Index range 1..Max_Cars_On_Vehicle) + of Motivators.Car; + type Auto_Carrier is new Motivators.Truck(18) with + record + Load_Count : Cargo_Index := 0; + Payload : Cargo; + end record; + procedure TC_Validate( It: Auto_Carrier; Key: Vehicle.TC_Keys ); + procedure Load ( The_Car : in Motivators.Car; + Onto : in out Auto_Carrier); + procedure Unload( The_Car : out Motivators.Car; + Off_of : in out Auto_Carrier); +end C390003_3; + +----------------------------------------------------------------- C390003_4 + +with C390003_1; +with C390003_2; +package C390003_4 is -- James_Bond + + package Vehicle renames C390003_1; + package Motivators renames C390003_2; + + type Q_Machine is new Vehicle.Object(4) with record + Car_Part : Motivators.Car; + Bike_Part : Motivators.Motorcycle; + end record; + procedure TC_Validate( It: Q_Machine; Key: Vehicle.TC_Keys ); + +end C390003_4; + +----------------------------------------------------------------- C390003_1 + +with Report; +with Ada.Tags; +package body C390003_1 is -- Vehicle + + function "="(A,B: Ada.Tags.Tag) return Boolean renames Ada.Tags."="; + + procedure TC_Validate( It: Object; Key: TC_Keys ) is + begin + if Key /= Veh then + Report.Failed("Expected Veh Key"); + end if; + end TC_Validate; + + procedure TC_Validate( It: Object'Class; The_Tag: Ada.Tags.Tag ) is + begin + if It'Tag /= The_Tag then + Report.Failed("Unexpected Tag for classwide formal"); + end if; + end TC_Validate; + + procedure Create( The_Vehicle : in out Object; Tyres : in States ) is + begin + The_Vehicle.Wheel_State := ( others => Tyres ); + end Create; + + function Wheels( The_Vehicle : Object ) return Positive is + begin + return The_Vehicle.Wheels; + end Wheels; + + procedure Rotate( The_Vehicle : in out Object ) is + Push : States; + Pulled : States + := The_Vehicle.Wheel_State(The_Vehicle.Wheel_State'Last); + begin + for Finger in + The_Vehicle.Wheel_State'First..The_Vehicle.Wheel_State'Last loop + Push := The_Vehicle.Wheel_State(Finger); + The_Vehicle.Wheel_State(Finger) := Pulled; + Pulled := Push; + end loop; + end Rotate; + +end C390003_1; -- Vehicle; + +----------------------------------------------------------------- C390003_2 + +with Ada.Tags; +with Report; +package body C390003_2 is -- Motivators + + function "="(A,B: Ada.Tags.Tag) return Boolean renames Ada.Tags."="; + function "="(A,B: Vehicle.TC_Keys) return Boolean renames Vehicle."="; + + procedure TC_Validate( It: Motorcycle; Key: Vehicle.TC_Keys ) is + begin + if Key /= Vehicle.MC then + Report.Failed("Expected MC Key"); + end if; + end TC_Validate; + + procedure TC_Validate( It: Tandem; Key: Vehicle.TC_Keys ) is + begin + if Key /= Vehicle.Tand then + Report.Failed("Expected Tand Key"); + end if; + end TC_Validate; + + procedure TC_Validate( It: Car; Key: Vehicle.TC_Keys ) is + begin + if Key /= Vehicle.Car then + Report.Failed("Expected Car Key"); + end if; + end TC_Validate; + + procedure TC_Validate( It: Truck; Key: Vehicle.TC_Keys ) is + begin + if Key /= Vehicle.Truk then + Report.Failed("Expected Truk Key"); + end if; + end TC_Validate; +end C390003_2; -- Motivators; + +----------------------------------------------------------------- C390003_3 + +with Ada.Tags; +with Report; +package body C390003_3 is -- Special_Trucks + + function "="(A,B: Ada.Tags.Tag) return Boolean renames Ada.Tags."="; + function "="(A,B: Vehicle.TC_Keys) return Boolean renames Vehicle."="; + + procedure TC_Validate( It: Auto_Carrier; Key: Vehicle.TC_Keys ) is + begin + if Key /= Vehicle.Heavy then + Report.Failed("Expected Heavy Key"); + end if; + end TC_Validate; + + procedure Load ( The_Car : in Motivators.Car; + Onto : in out Auto_Carrier) is + begin + Onto.Load_Count := Onto.Load_Count +1; + Onto.Payload(Onto.Load_Count) := The_Car; + end Load; + procedure Unload( The_Car : out Motivators.Car; + Off_of : in out Auto_Carrier) is + begin + The_Car := Off_of.Payload(Off_of.Load_Count); + Off_of.Load_Count := Off_of.Load_Count -1; + end Unload; + +end C390003_3; + +----------------------------------------------------------------- C390003_4 + +with Report, Ada.Tags; +package body C390003_4 is -- James_Bond + + function "="(A,B: Ada.Tags.Tag) return Boolean renames Ada.Tags."="; + function "="(A,B: Vehicle.TC_Keys) return Boolean renames Vehicle."="; + + procedure TC_Validate( It: Q_Machine; Key: Vehicle.TC_Keys ) is + begin + if Key /= Vehicle.Q then + Report.Failed("Expected Q Key"); + end if; + end TC_Validate; + +end C390003_4; + +------------------------------------------------------------------- C390003 + +with Report; +with C390003_1; +with C390003_2; +with C390003_3; +with C390003_4; +procedure C390003 is + + package Vehicle renames C390003_1; use Vehicle; + package Motivators renames C390003_2; + package Special_Trucks renames C390003_3; + package James_Bond renames C390003_4; + + -- The cast, in order of complexity: + + Pennys_Bike : Motivators.Bicycle; + Weekender : Motivators.Tandem; + Qs_Moped : Motivators.Motorcycle; + Ms_Limo : Motivators.Car; + Yard_Van : Motivators.Truck(8); + Specter_X : Special_Trucks.Auto_Carrier; + Gen_II : James_Bond.Q_Machine; + + + -- Check compatibility with the corresponding class wide type. + + procedure Vehicle_Shop( It : in out Vehicle.Object'Class; + Key : in Vehicle.TC_Keys ) is + + -- Check that Subtype'Class is defined for tagged subtypes. + procedure Bike_Shop( Bike: in out Motivators.Bicycle'Class ) is + begin + -- Dispatch to appropriate TC_Validate + Vehicle.TC_Validate( Bike, Key ); + end Bike_Shop; + + begin + Vehicle.TC_Validate( It, Key ); + if Vehicle.Wheels( It ) = 2 then + Bike_Shop( It ); -- only call Bike_Shop when It has 2 wheels + end if; + end Vehicle_Shop; + +begin -- Main test procedure. + + Report.Test ("C390003", "Check that for a subtype S of a tagged type " & + "T, S'Class denotes a class-wide subtype. Check that " & + "T'Tag denotes the tag of the type T, and that, for a " & + "class-wide tagged type X, X'Tag denotes the tag of X. " & + "Check that the tags of stand alone objects, record and " & + "array components, aggregates, and formal parameters " & + "identify their type. Check that the tag of a value of a " & + "formal parameter is that of the actual parameter, even " & + "if the actual is passed by a view conversion" ); + +-- Check that the tags of stand alone objects, record and array +-- components, aggregates, and formal parameters identify their type. +-- Check that the tag of a value of a formal parameter is that of the +-- actual parameter, even if the actual is passed by a view conversion. + + Vehicle_Shop( Pennys_Bike, Veh ); + Vehicle_Shop( Weekender, Tand ); + Vehicle_Shop( Qs_Moped, MC ); + Vehicle_Shop( Ms_Limo, Car ); + Vehicle_Shop( Yard_Van, Truk ); + Vehicle_Shop( Specter_X, Heavy ); + Vehicle_Shop( Specter_X.Payload(1), Car ); + Vehicle_Shop( Gen_II, Q ); + Vehicle_Shop( Gen_II.Car_Part, Car ); + Vehicle_Shop( Gen_II.Bike_Part, MC ); + + Vehicle.TC_Validate( Pennys_Bike, Vehicle.Object'Tag ); + Vehicle.TC_Validate( Weekender, Motivators.Tandem'Tag ); + Vehicle.TC_Validate( Qs_Moped, Motivators.Motorcycle'Tag ); + Vehicle.TC_Validate( Ms_Limo, Motivators.Car'Tag ); + Vehicle.TC_Validate( Yard_Van, Motivators.Truck'Tag ); + Vehicle.TC_Validate( Specter_X, Special_Trucks.Auto_Carrier'Tag ); + Vehicle.TC_Validate( Specter_X.Payload(1), Motivators.Car'Tag ); + Vehicle.TC_Validate( Gen_II, James_Bond.Q_Machine'Tag ); + Vehicle.TC_Validate( Gen_II.Car_Part, Motivators.Car'Tag ); + Vehicle.TC_Validate( Gen_II.Bike_Part, Motivators.Motorcycle'Tag ); + +-- Check the tag generated for an aggregate. + + Rentals: declare + Mikes_Rental : Vehicle.Object'Class := + Vehicle.Object'( 3, (Good, Flat, Worn)); + Diannes_Car : Vehicle.Object'Class := + Motivators.Tandem'( Wheels => 2, + Wheel_State => (Good, Good) ); + Jims_Bike : Vehicle.Object'Class := + Motivators.Motorcycle'( Pennys_Bike + with Displacement => 350 ); + Bills_Limo : Vehicle.Object'Class := + Motivators.Car'( Wheels => 4, + Wheel_State => (others => Good), + Displacement => 282 ); + Alans_Car : Vehicle.Object'Class := + Motivators.Truck'( 18, (others => Worn), + Tare => 5_500 ); + Pats_Truck : Vehicle.Object'Class := Specter_X; + Keiths_Car : Vehicle.Object'Class := Gen_II; + Isaacs_Bus : Vehicle.Object'Class := Keiths_Car; + + begin + Vehicle.TC_Validate( Mikes_Rental, Vehicle.Object'Tag ); + Vehicle.TC_Validate( Diannes_Car, Motivators.Tandem'Tag ); + Vehicle.TC_Validate( Jims_Bike, Motivators.Motorcycle'Tag ); + Vehicle.TC_Validate( Bills_Limo, Motivators.Car'Tag ); + Vehicle.TC_Validate( Alans_Car, Motivators.Truck'Tag ); + Vehicle.TC_Validate( Pats_Truck, Special_Trucks.Auto_Carrier'Tag ); + Vehicle.TC_Validate( Keiths_Car, James_Bond.Q_Machine'Tag ); + end Rentals; + +-- Check the tag of parameters. +-- Check that the tag is not affected by view conversion. + + Vehicle.TC_Validate( Vehicle.Object( Gen_II ), James_Bond.Q_Machine'Tag ); + Vehicle.TC_Validate( Vehicle.Object( Ms_Limo ), Motivators.Car'Tag ); + Vehicle.TC_Validate( Motivators.Bicycle( Weekender ), + Motivators.Tandem'Tag ); + Vehicle.TC_Validate( Motivators.Bicycle( Gen_II.Bike_Part ), + Motivators.Motorcycle'Tag ); + + Report.Result; + +end C390003; diff --git a/gcc-4.9/gcc/testsuite/ada/acats/tests/c3/c390004.a b/gcc-4.9/gcc/testsuite/ada/acats/tests/c3/c390004.a new file mode 100644 index 000000000..2c120bab9 --- /dev/null +++ b/gcc-4.9/gcc/testsuite/ada/acats/tests/c3/c390004.a @@ -0,0 +1,404 @@ +-- C390004.A +-- +-- Grant of Unlimited Rights +-- +-- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687, +-- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained +-- unlimited rights in the software and documentation contained herein. +-- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making +-- this public release, the Government intends to confer upon all +-- recipients unlimited rights equal to those held by the Government. +-- These rights include rights to use, duplicate, release or disclose the +-- released technical data and computer software in whole or in part, in +-- any manner and for any purpose whatsoever, and to have or permit others +-- to do so. +-- +-- DISCLAIMER +-- +-- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR +-- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED +-- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE +-- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE +-- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A +-- PARTICULAR PURPOSE OF SAID MATERIAL. +--* +-- +-- OBJECTIVE: +-- Check that the tags of allocated objects correctly identify the +-- type of the allocated object. Check that the tag corresponds +-- correctly to the value resulting from both normal and view +-- conversion. Check that the tags of accessed values designating +-- aliased objects correctly identify the type of the object. Check +-- that the tag of a function result correctly evaluates. Check this +-- for class-wide functions. The tag of a class-wide function result +-- should be the tag appropriate to the actual value returned, not the +-- tag of the ancestor type. +-- +-- TEST DESCRIPTION: +-- This test defines a class hierarchy of types, with reference +-- semantics (an access type to the class-wide type). Similar in +-- structure to C392005, this test checks that dynamic allocation does +-- not adversely impact the tagging of types. +-- +-- +-- CHANGE HISTORY: +-- 06 Dec 94 SAIC ACVC 2.0 +-- +--! + +package C390004_1 is -- DMV + type Equipment is ( T_Veh, T_Car, T_Con, T_Jep ); + + type Vehicle is tagged record + Wheels : Natural := 4; + Parked : Boolean := False; + end record; + + function Wheels ( It: Vehicle ) return Natural; + procedure Park ( It: in out Vehicle ); + procedure UnPark ( It: in out Vehicle ); + procedure Set_Wheels( It: in out Vehicle; To_Count: in Natural ); + procedure TC_Check ( It: in Vehicle; To_Equip: in Equipment ); + + type Car is new Vehicle with record + Passengers : Natural := 0; + end record; + + function Passengers ( It: Car ) return Natural; + procedure Load_Passengers( It: in out Car; To_Count: in Natural ); + procedure Park ( It: in out Car ); + procedure TC_Check ( It: in Car; To_Equip: in Equipment ); + + type Convertible is new Car with record + Top_Up : Boolean := True; + end record; + + function Top_Up ( It: Convertible ) return Boolean; + procedure Lower_Top( It: in out Convertible ); + procedure Park ( It: in out Convertible ); + procedure Raise_Top( It: in out Convertible ); + procedure TC_Check ( It: in Convertible; To_Equip: in Equipment ); + + type Jeep is new Convertible with record + Windshield_Up : Boolean := True; + end record; + + function Windshield_Up ( It: Jeep ) return Boolean; + procedure Lower_Windshield( It: in out Jeep ); + procedure Park ( It: in out Jeep ); + procedure Raise_Windshield( It: in out Jeep ); + procedure TC_Check ( It: in Jeep; To_Equip: in Equipment ); + +end C390004_1; + +with Report; +package body C390004_1 is + + procedure Set_Wheels( It: in out Vehicle; To_Count: in Natural ) is + begin + It.Wheels := To_Count; + end Set_Wheels; + + function Wheels( It: Vehicle ) return Natural is + begin + return It.Wheels; + end Wheels; + + procedure Park ( It: in out Vehicle ) is + begin + It.Parked := True; + end Park; + + procedure UnPark ( It: in out Vehicle ) is + begin + It.Parked := False; + end UnPark; + + procedure TC_Check ( It: in Vehicle; To_Equip: in Equipment ) is + begin + if To_Equip /= T_Veh then + Report.Failed ("Failed, called Vehicle for " + & Equipment'Image(To_Equip)); + end if; + end TC_Check; + + procedure TC_Check ( It: in Car; To_Equip: in Equipment ) is + begin + if To_Equip /= T_Car then + Report.Failed ("Failed, called Car for " + & Equipment'Image(To_Equip)); + end if; + end TC_Check; + + procedure TC_Check ( It: in Convertible; To_Equip: in Equipment ) is + begin + if To_Equip /= T_Con then + Report.Failed ("Failed, called Convertible for " + & Equipment'Image(To_Equip)); + end if; + end TC_Check; + + procedure TC_Check ( It: in Jeep; To_Equip: in Equipment ) is + begin + if To_Equip /= T_Jep then + Report.Failed ("Failed, called Jeep for " + & Equipment'Image(To_Equip)); + end if; + end TC_Check; + + procedure Load_Passengers( It: in out Car; To_Count: in Natural ) is + begin + It.Passengers := To_Count; + UnPark( It ); + end Load_Passengers; + + procedure Park( It: in out Car ) is + begin + It.Passengers := 0; + Park( Vehicle( It ) ); + end Park; + + function Passengers( It: Car ) return Natural is + begin + return It.Passengers; + end Passengers; + + procedure Raise_Top( It: in out Convertible ) is + begin + It.Top_Up := True; + end Raise_Top; + + procedure Lower_Top( It: in out Convertible ) is + begin + It.Top_Up := False; + end Lower_Top; + + function Top_Up ( It: Convertible ) return Boolean is + begin + return It.Top_Up; + end Top_Up; + + procedure Park ( It: in out Convertible ) is + begin + It.Top_Up := True; + Park( Car( It ) ); + end Park; + + procedure Raise_Windshield( It: in out Jeep ) is + begin + It.Windshield_Up := True; + end Raise_Windshield; + + procedure Lower_Windshield( It: in out Jeep ) is + begin + It.Windshield_Up := False; + end Lower_Windshield; + + function Windshield_Up( It: Jeep ) return Boolean is + begin + return It.Windshield_Up; + end Windshield_Up; + + procedure Park( It: in out Jeep ) is + begin + It.Windshield_Up := True; + Park( Convertible( It ) ); + end Park; +end C390004_1; + +with Report; +with Ada.Tags; +with C390004_1; +procedure C390004 is + package DMV renames C390004_1; + + The_Vehicle : aliased DMV.Vehicle; + The_Car : aliased DMV.Car; + The_Convertible : aliased DMV.Convertible; + The_Jeep : aliased DMV.Jeep; + + type C_Reference is access all DMV.Car'Class; + type V_Reference is access all DMV.Vehicle'Class; + + Designator : V_Reference; + Storage : Natural; + + procedure Valet( It: in out DMV.Vehicle'Class ) is + begin + DMV.Park( It ); + end Valet; + + procedure TC_Match( Object: DMV.Vehicle'Class; + Taglet: Ada.Tags.Tag; + Where : String ) is + use Ada.Tags; + begin + if Object'Tag /= Taglet then + Report.Failed("Tag mismatch: " & Where); + end if; + end TC_Match; + + procedure Parking_Validation( It: DMV.Vehicle; TC_Message: String ) is + begin + if DMV.Wheels( It ) /= 1 or not It.Parked then + Report.Failed ("Failed Vehicle " & TC_Message); + end if; + end Parking_Validation; + + procedure Parking_Validation( It: DMV.Car; TC_Message: String ) is + begin + if DMV.Wheels( It ) /= 2 or DMV.Passengers( It ) /= 0 + or not It.Parked then + Report.Failed ("Failed Car " & TC_Message); + end if; + end Parking_Validation; + + procedure Parking_Validation( It: DMV.Convertible; + TC_Message: String ) is + begin + if DMV.Wheels( It ) /= 3 or DMV.Passengers( It ) /= 0 + or not DMV.Top_Up( It ) or not It.Parked then + Report.Failed ("Failed Convertible " & TC_Message); + end if; + end Parking_Validation; + + procedure Parking_Validation( It: DMV.Jeep; TC_Message: String ) is + begin + if DMV.Wheels( It ) /= 4 or DMV.Passengers( It ) /= 0 + or not DMV.Top_Up( It ) or not DMV.Windshield_Up( It ) + or not It.Parked then + Report.Failed ("Failed Jeep " & TC_Message); + end if; + end Parking_Validation; + + function Wash( It: V_Reference; TC_Expect : Ada.Tags.Tag ) + return DMV.Vehicle'Class is + This_Machine : DMV.Vehicle'Class := It.all; + begin + TC_Match( It.all, TC_Expect, "Class-wide object in Wash" ); + Storage := DMV.Wheels( This_Machine ); + return This_Machine; + end Wash; + + function Wash( It: C_Reference; TC_Expect : Ada.Tags.Tag ) + return DMV.Car'Class is + This_Machine : DMV.Car'Class := It.all; + begin + TC_Match( It.all, TC_Expect, "Class-wide object in Wash" ); + Storage := DMV.Wheels( This_Machine ); + return This_Machine; + end Wash; + +begin + + Report.Test( "C390004", "Check that the tags of allocated objects " + & "correctly identify the type of the allocated " + & "object. Check that tags resulting from " + & "normal and view conversions. Check tags of " + & "accessed values designating aliased objects. " + & "Check function result tags" ); + + DMV.Set_Wheels( The_Vehicle, 1 ); + DMV.Set_Wheels( The_Car, 2 ); + DMV.Set_Wheels( The_Convertible, 3 ); + DMV.Set_Wheels( The_Jeep, 4 ); + + Valet( The_Vehicle ); + Valet( The_Car ); + Valet( The_Convertible ); + Valet( The_Jeep ); + + Parking_Validation( The_Vehicle, "setup" ); + Parking_Validation( The_Car, "setup" ); + Parking_Validation( The_Convertible, "setup" ); + Parking_Validation( The_Jeep, "setup" ); + +-- Check that the tags of allocated objects correctly identify the type +-- of the allocated object. + + Designator := new DMV.Vehicle; + DMV.TC_Check( Designator.all, DMV.T_Veh ); + TC_Match( Designator.all, DMV.Vehicle'Tag, "allocated Vehicle" ); + + Designator := new DMV.Car; + DMV.TC_Check( Designator.all, DMV.T_Car ); + TC_Match( Designator.all, DMV.Car'Tag, "allocated Car"); + + Designator := new DMV.Convertible; + DMV.TC_Check( Designator.all, DMV.T_Con ); + TC_Match( Designator.all, DMV.Convertible'Tag, "allocated Convertible" ); + + Designator := new DMV.Jeep; + DMV.TC_Check( Designator.all, DMV.T_Jep ); + TC_Match( Designator.all, DMV.Jeep'Tag, "allocated Jeep" ); + +-- Check that view conversion causes the correct dispatch + DMV.TC_Check( DMV.Vehicle( The_Jeep ), DMV.T_Veh ); + DMV.TC_Check( DMV.Car( The_Jeep ), DMV.T_Car ); + DMV.TC_Check( DMV.Convertible( The_Jeep ), DMV.T_Con ); + +-- And that view conversion does not change the tag + TC_Match( DMV.Vehicle( The_Jeep ), DMV.Jeep'Tag, "View Conv Veh" ); + TC_Match( DMV.Car( The_Jeep ), DMV.Jeep'Tag, "View Conv Car" ); + TC_Match( DMV.Convertible( The_Jeep ), DMV.Jeep'Tag, "View Conv Jep" ); + +-- Check that the tags of accessed values designating aliased objects +-- correctly identify the type of the object. + Designator := The_Vehicle'Access; + DMV.TC_Check( Designator.all, DMV.T_Veh ); + TC_Match( Designator.all, DMV.Vehicle'Tag, "aliased Vehicle" ); + + Designator := The_Car'Access; + DMV.TC_Check( Designator.all, DMV.T_Car ); + TC_Match( Designator.all, DMV.Car'Tag, "aliased Car" ); + + Designator := The_Convertible'Access; + DMV.TC_Check( Designator.all, DMV.T_Con ); + TC_Match( Designator.all, DMV.Convertible'Tag, "aliased Convertible" ); + + Designator := The_Jeep'Access; + DMV.TC_Check( Designator.all, DMV.T_Jep ); + TC_Match( Designator.all, DMV.Jeep'Tag, "aliased Jeep" ); + +-- Check that the tag of a function result correctly evaluates. +-- Check this for class-wide functions. The tag of a class-wide +-- function result should be the tag appropriate to the actual value +-- returned, not the tag of the ancestor type. + Function_Check: declare + A_Vehicle : V_Reference := new DMV.Vehicle'( The_Vehicle ); + A_Car : C_Reference := new DMV.Car'( The_Car ); + A_Convertible : C_Reference := new DMV.Convertible'( The_Convertible ); + A_Jeep : C_Reference := new DMV.Jeep'( The_Jeep ); + begin + DMV.Unpark( A_Vehicle.all ); + DMV.Load_Passengers( A_Car.all, 5 ); + DMV.Load_Passengers( A_Convertible.all, 6 ); + DMV.Load_Passengers( A_Jeep.all, 7 ); + DMV.Lower_Top( DMV.Convertible(A_Convertible.all) ); + DMV.Lower_Top( DMV.Jeep(A_Jeep.all) ); + DMV.Lower_Windshield( DMV.Jeep(A_Jeep.all) ); + + if DMV.Wheels( Wash( A_Jeep, DMV.Jeep'Tag ) ) /= 4 + or Storage /= 4 then + Report.Failed("Did not correctly wash Jeep"); + end if; + + if DMV.Wheels( Wash( A_Convertible, DMV.Convertible'Tag ) ) /= 3 + or Storage /= 3 then + Report.Failed("Did not correctly wash Convertible"); + end if; + + if DMV.Wheels( Wash( A_Car, DMV.Car'Tag ) ) /= 2 + or Storage /= 2 then + Report.Failed("Did not correctly wash Car"); + end if; + + if DMV.Wheels( Wash( A_Vehicle, DMV.Vehicle'Tag ) ) /= 1 + or Storage /= 1 then + Report.Failed("Did not correctly wash Vehicle"); + end if; + + end Function_Check; + + Report.Result; +end C390004; diff --git a/gcc-4.9/gcc/testsuite/ada/acats/tests/c3/c3900050.a b/gcc-4.9/gcc/testsuite/ada/acats/tests/c3/c3900050.a new file mode 100644 index 000000000..8a00b2656 --- /dev/null +++ b/gcc-4.9/gcc/testsuite/ada/acats/tests/c3/c3900050.a @@ -0,0 +1,157 @@ +-- C3900050.A +-- +-- Grant of Unlimited Rights +-- +-- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687, +-- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained +-- unlimited rights in the software and documentation contained herein. +-- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making +-- this public release, the Government intends to confer upon all +-- recipients unlimited rights equal to those held by the Government. +-- These rights include rights to use, duplicate, release or disclose the +-- released technical data and computer software in whole or in part, in +-- any manner and for any purpose whatsoever, and to have or permit others +-- to do so. +-- +-- DISCLAIMER +-- +-- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR +-- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED +-- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE +-- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE +-- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A +-- PARTICULAR PURPOSE OF SAID MATERIAL. +--* +-- +-- OBJECTIVE: +-- See C3900053.AM. +-- +-- TEST DESCRIPTION: +-- See C3900053.AM. +-- +-- TEST FILES: +-- This test consists of the following files: +-- +-- => C3900050.A +-- C3900051.A +-- C3900052.A +-- C3900053.AM +-- +-- CHANGE HISTORY: +-- 06 Dec 94 SAIC ACVC 2.0 +-- 15 May 96 SAIC ACVC 2.1: Modified prologue. Added pragma Elaborate +-- for Ada.Calendar. +-- +--! + +with Ada.Calendar; +pragma Elaborate (Ada.Calendar); + +package C3900050 is -- Alert system abstraction. + + -- Declarations used by component Arrival_Time. + + Default_Time : constant Ada.Calendar.Time := + Ada.Calendar.Time_Of (1901, 1, 1); + Alert_Time : constant Ada.Calendar.Time := + Ada.Calendar.Time_Of (1991, 6, 15); + + + -- Declarations used by component Display_On and procedure Display. + + type Device_Enum is (Null_Device, Teletype, Console, Big_Screen); + type Display_Counters is array (Device_Enum) of Natural; + + Display_Count_For : Display_Counters := (others => 0); + + + + type Alert_Type is tagged private; -- Root tagged type. + + procedure Set_Display (A : in out Alert_Type; -- To be inherited by + D : in Device_Enum); -- all derivatives. + + procedure Display (A : in Alert_Type); -- To be inherited by + -- all derivatives. + + procedure Handle (A : in out Alert_Type); -- To be overridden by + -- all derivatives. + + + -- The following functions are needed to verify the values of the + -- root tagged type's private components. + + function Get_Time (A: Alert_Type) return Ada.Calendar.Time; + + function Get_Display (A: Alert_Type) return Device_Enum; + + function Initial_Values_Okay (A : in Alert_Type) + return Boolean; + + function Bad_Final_Values (A : in Alert_Type) + return Boolean; + +private + + type Alert_Type is tagged record -- Root tagged type. + Arrival_Time : Ada.Calendar.Time := Default_Time; + Display_On : Device_Enum := Null_Device; + end record; + + +end C3900050; + + + --==================================================================-- + + +package body C3900050 is -- Alert system abstraction. + + + procedure Set_Display (A : in out Alert_Type; + D : in Device_Enum) is + begin + A.Display_On := D; + end Set_Display; + + + procedure Display (A : in Alert_Type) is + begin + Display_Count_For (A.Display_On) := Display_Count_For (A.Display_On) + 1; + end Display; + + + procedure Handle (A : in out Alert_Type) is + begin + A.Arrival_Time := Alert_Time; + Display (A); + end Handle; + + + function Get_Time (A: Alert_Type) return Ada.Calendar.Time is + begin + return A.Arrival_Time; + end Get_Time; + + + function Get_Display (A: Alert_Type) return Device_Enum is + begin + return A.Display_On; + end Get_Display; + + + function Initial_Values_Okay (A : in Alert_Type) return Boolean is + begin + return (A = (Arrival_Time => Default_Time, -- Check "=" operator + Display_On => Null_Device)); -- availability. + end Initial_Values_Okay; -- Aggregate with + -- named associations. + + function Bad_Final_Values (A : in Alert_Type) return Boolean is + begin + return (A /= (Alert_Time, Null_Device)); -- Check "/=" operator + -- availability. + end Bad_Final_Values; -- Aggregate with + -- positional assoc. + +end C3900050; diff --git a/gcc-4.9/gcc/testsuite/ada/acats/tests/c3/c3900051.a b/gcc-4.9/gcc/testsuite/ada/acats/tests/c3/c3900051.a new file mode 100644 index 000000000..d23a62bff --- /dev/null +++ b/gcc-4.9/gcc/testsuite/ada/acats/tests/c3/c3900051.a @@ -0,0 +1,137 @@ +-- C3900051.A +-- +-- Grant of Unlimited Rights +-- +-- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687, +-- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained +-- unlimited rights in the software and documentation contained herein. +-- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making +-- this public release, the Government intends to confer upon all +-- recipients unlimited rights equal to those held by the Government. +-- These rights include rights to use, duplicate, release or disclose the +-- released technical data and computer software in whole or in part, in +-- any manner and for any purpose whatsoever, and to have or permit others +-- to do so. +-- +-- DISCLAIMER +-- +-- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR +-- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED +-- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE +-- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE +-- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A +-- PARTICULAR PURPOSE OF SAID MATERIAL. +--* +-- +-- OBJECTIVE: +-- See C3900053.AM. +-- +-- TEST DESCRIPTION: +-- See C3900053.AM. +-- +-- TEST FILES: +-- This test consists of the following files: +-- +-- C3900050.A +-- => C3900051.A +-- C3900052.A +-- C3900053.AM +-- +-- CHANGE HISTORY: +-- 06 Dec 94 SAIC ACVC 2.0 +-- 15 May 96 SAIC ACVC 2.1: Modified prologue. Added pragma Elaborate +-- for Ada.Calendar. +-- +--! + +with C3900050; -- Alert system abstraction. +package C3900051 is -- Extended alert system abstraction. + + + type Low_Alert_Type is new C3900050.Alert_Type + with private; -- Private extension of + -- root tagged type. + + -- Inherits procedure Display from Alert_Type. + + procedure Handle (LA : in out Low_Alert_Type); -- Override parent's + -- primitive subprog. + + procedure Set_Level (LA : in out Low_Alert_Type; -- To be inherited by + L : in Integer); -- all derivatives. + + + -- The following functions are needed to verify the values of the + -- extension's private components. + + function Get_Level (LA: Low_Alert_Type) return Integer; + + function Initial_Values_Okay (LA : in Low_Alert_Type) + return Boolean; -- Override parent's + -- primitive subprog. + + function Bad_Final_Values (LA : in Low_Alert_Type) -- Override parent's + return Boolean; -- primitive subprog. + + +private + + type Low_Alert_Type is new C3900050.Alert_Type with record + Level : Integer := 0; + end record; + +end C3900051; + + + --==================================================================-- + + +with Ada.Calendar; +pragma Elaborate (Ada.Calendar); + +package body C3900051 is -- Extended alert system abstraction. + + use C3900050; -- Alert system abstraction. + + + procedure Set_Level (LA : in out Low_Alert_Type; + L : in Integer) is + begin + LA.Level := L; + end Set_Level; + + + procedure Handle (LA : in out Low_Alert_Type) is + begin + Handle (Alert_Type (LA)); -- Call parent's operation (type conversion). + Set_Level (LA, 1); -- Call newly declared operation. + Set_Display (Alert_Type(LA), + Teletype); -- Call parent's operation (type conversion). + Display (LA); + end Handle; + + + function Get_Level (LA: Low_Alert_Type) return Integer is + begin + return LA.Level; + end Get_Level; + + + function Initial_Values_Okay (LA : in Low_Alert_Type) return Boolean is + begin + -- Call parent's operation (type conversion). + return (Initial_Values_Okay (Alert_Type (LA)) and + LA.Level = 0); + end Initial_Values_Okay; + + + function Bad_Final_Values (LA : in Low_Alert_Type) return Boolean is + use type Ada.Calendar.Time; + begin + return (Get_Time(LA) /= Alert_Time or + Get_Display(LA) /= Teletype or + LA.Level /= 1); + end Bad_Final_Values; + + +end C3900051; diff --git a/gcc-4.9/gcc/testsuite/ada/acats/tests/c3/c3900052.a b/gcc-4.9/gcc/testsuite/ada/acats/tests/c3/c3900052.a new file mode 100644 index 000000000..11d26db4a --- /dev/null +++ b/gcc-4.9/gcc/testsuite/ada/acats/tests/c3/c3900052.a @@ -0,0 +1,138 @@ +-- C3900052.A +-- +-- Grant of Unlimited Rights +-- +-- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687, +-- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained +-- unlimited rights in the software and documentation contained herein. +-- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making +-- this public release, the Government intends to confer upon all +-- recipients unlimited rights equal to those held by the Government. +-- These rights include rights to use, duplicate, release or disclose the +-- released technical data and computer software in whole or in part, in +-- any manner and for any purpose whatsoever, and to have or permit others +-- to do so. +-- +-- DISCLAIMER +-- +-- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR +-- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED +-- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE +-- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE +-- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A +-- PARTICULAR PURPOSE OF SAID MATERIAL. +--* +-- +-- OBJECTIVE: +-- See C3900053.AM. +-- +-- TEST DESCRIPTION: +-- See C3900053.AM. +-- +-- TEST FILES: +-- This test consists of the following files: +-- +-- C3900050.A +-- C3900051.A +-- => C3900052.A +-- C3900053.AM +-- +-- CHANGE HISTORY: +-- 06 Dec 94 SAIC ACVC 2.0 +-- 15 May 96 SAIC ACVC 2.1: Modified prologue. Added pragma Elaborate +-- for Ada.Calendar. +-- +--! + +with C3900051; -- Extended alert system abstraction. +package C3900052 is -- Further extended alert system abstraction. + + + -- Declarations used by component Action_Officer; + + type Person_Enum is (Nobody, Duty_Officer, + Watch_Commander, Commanding_Officer); + + + type Medium_Alert_Type is new C3900051.Low_Alert_Type + with private; -- Private extension of + -- private extension. + + -- Inherits (inherited) procedure Display from Low_Alert_Type. + -- Inherits function Level_Of from Low_Alert_Type. + + procedure Handle (MA : in out Medium_Alert_Type); -- Override parent's + -- primitive subprog. + + procedure Assign_Officer (MA : in out Medium_Alert_Type; + To : in Person_Enum); + + + -- The following functions are needed to verify the values of the + -- extension's private components. + + function Initial_Values_Okay (MA : in Medium_Alert_Type) + return Boolean; -- Override parent's + -- primitive subprog. + + function Bad_Final_Values (MA: in Medium_Alert_Type) -- Override parent's + return Boolean; -- primitive subprog. + +private + + type Medium_Alert_Type is new C3900051.Low_Alert_Type with record + Action_Officer : Person_Enum := Nobody; + end record; + +end C3900052; + + + --==================================================================-- + + +with C3900050; -- Basic alert abstraction. +with Ada.Calendar; +pragma Elaborate (Ada.Calendar); + +package body C3900052 is -- Further extended alert system abstraction. + + use C3900050; -- Enumeration values directly visible. + use C3900051; -- Extended alert system abstraction. + + + procedure Assign_Officer (MA : in out Medium_Alert_Type; + To : in Person_Enum) is + begin + MA.Action_Officer := To; + end Assign_Officer; + + + procedure Handle (MA : in out Medium_Alert_Type) is + begin + Handle (Low_Alert_Type (MA)); -- Call parent's op (type conversion). + Set_Level (MA, 2); -- Call inherited operation. + Assign_Officer (MA, Duty_Officer); -- Call newly declared operation. + Set_Display (MA, Console); -- Call inherited operation. + Display (MA); -- Call doubly inherited operation. + end Handle; + + + function Initial_Values_Okay (MA : in Medium_Alert_Type) return Boolean is + begin + -- Call parent's operation (type conversion). + return (Initial_Values_Okay (Low_Alert_Type (MA)) and + MA.Action_Officer = Nobody); + end Initial_Values_Okay; + + + function Bad_Final_Values (MA : in Medium_Alert_Type) return Boolean is + use type Ada.Calendar.Time; + begin + return (Get_Time(MA) /= Alert_Time or + Get_Display(MA) /= Console or + Get_Level(MA) /= 2 or + MA.Action_Officer /= Duty_Officer); + end Bad_Final_Values; + + +end C3900052; diff --git a/gcc-4.9/gcc/testsuite/ada/acats/tests/c3/c3900053.am b/gcc-4.9/gcc/testsuite/ada/acats/tests/c3/c3900053.am new file mode 100644 index 000000000..8ea3c118a --- /dev/null +++ b/gcc-4.9/gcc/testsuite/ada/acats/tests/c3/c3900053.am @@ -0,0 +1,191 @@ +-- C3900053.AM +-- +-- Grant of Unlimited Rights +-- +-- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687, +-- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained +-- unlimited rights in the software and documentation contained herein. +-- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making +-- this public release, the Government intends to confer upon all +-- recipients unlimited rights equal to those held by the Government. +-- These rights include rights to use, duplicate, release or disclose the +-- released technical data and computer software in whole or in part, in +-- any manner and for any purpose whatsoever, and to have or permit others +-- to do so. +-- +-- DISCLAIMER +-- +-- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR +-- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED +-- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE +-- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE +-- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A +-- PARTICULAR PURPOSE OF SAID MATERIAL. +--* +-- +-- OBJECTIVE: +-- Check that a private tagged type declared in a package specification +-- may be extended with a private extension in a different package +-- specification, and that this private extension may in turn be extended +-- by a private extension in a third package. +-- +-- Check that each derivative inherits the user-defined primitive +-- subprograms of its parent (including those that its parent inherited), +-- that it may override these inherited primitive subprograms, and that it +-- may also declare its own primitive subprograms. +-- +-- Check that type conversion is defined from a type extension to its +-- parent, and that this parent itself may be a type extension. +-- +-- TEST DESCRIPTION: +-- Declare a root tagged private type and two associated primitive +-- subprograms in a package specification. Declare operations to verify +-- the correctness of the components. Declare operations which return +-- values of the type's private components, and which will be +-- inherited by later derivatives. +-- +-- Extend the root type with a private extension in a second package +-- specification. Declare a new primitive subprogram for the extension, +-- and override one of the two inherited subprograms. Within the +-- overriding subprogram, utilize type conversion to call the parent's +-- implementation of the same subprogram. Also within the overriding +-- subprogram, call the new primitive subprogram and each inherited +-- subprogram. Declare operations of the private extension which +-- override the verification operations of its parent. Declare operations +-- of the private extension which return values of the extension's +-- private components, and which will be inherited by later derivatives. +-- +-- Extend the extension with a private extension in a third package +-- specification. Declare a new primitive subprogram for this private +-- extension, and override one of the three inherited subprograms. +-- Within the overriding subprogram, utilize type conversion to call the +-- parent's implementation of the same subprogram. Also within the +-- overriding subprogram, call the new primitive subprogram and each +-- inherited subprogram. Declare operations of the private extension +-- which override the verification operations of its parent. +-- +-- In the main program, declare objects of the root tagged type and +-- the two type extensions. For each object, call the overriding +-- subprogram, and verify the correctness of the components by calling +-- the verification operations. +-- +-- TEST FILES: +-- This test consists of the following files: +-- +-- C3900050.A +-- C3900051.A +-- C3900052.A +-- => C3900053.AM +-- +-- +-- CHANGE HISTORY: +-- 06 Dec 94 SAIC ACVC 2.0 +-- 15 May 96 SAIC ACVC 2.1: Modified prologue. +-- +--! + +with Report; + +with C3900050; -- Basic alert abstraction. +with C3900051; -- Extended alert abstraction. +with C3900052; -- Further extended alert abstraction. + +use C3900050; -- Primitive operations of Alert_Type directly visible. + +procedure C3900053 is +begin + + Report.Test ("C390005", "Primitive operation inheritance by type " & + "extensions: root type is private; all extensions are " & + "private and declared in different packages"); + + + ALERT_SUBTEST: ------------------------------------------------------------- + + declare + Alarm : C3900050.Alert_Type; -- Root tagged private type. + begin + if not Initial_Values_Okay (Alarm) then + Report.Failed ("Wrong initial values for Alert_Type"); + end if; + + Handle (Alarm); + + if Bad_Final_Values (Alarm) then + Report.Failed ("Wrong values for Alert_Type after Handle"); + end if; + end Alert_Subtest; + + + -- Check intermediate display counts: + + if C3900050.Display_Count_For (Null_Device) /= 1 or + C3900050.Display_Count_For (Teletype) /= 0 or + C3900050.Display_Count_For (Console) /= 0 or + C3900050.Display_Count_For (Big_Screen) /= 0 + then + Report.Failed ("Wrong display counts after Alert_Type"); + end if; + + + LOW_ALERT_SUBTEST: --------------------------------------------------------- + + declare + Low_Alarm : C3900051.Low_Alert_Type; -- Priv. ext. of tagged type. + use C3900051; -- Primitive operations of extension directly visible. + begin + if not Initial_Values_Okay (Low_Alarm) then + Report.Failed ("Wrong initial values for Low_Alert_Type"); + end if; + + Handle (Low_Alarm); + + if Bad_Final_Values (Low_Alarm) then + Report.Failed ("Wrong values for Low_Alert_Type after Handle"); + end if; + end Low_Alert_Subtest; + + + -- Check intermediate display counts: + + if C3900050.Display_Count_For /= (Null_Device => 2, + Teletype => 1, + Console => 0, + Big_Screen => 0) + then + Report.Failed ("Wrong display counts after Low_Alert_Type"); + end if; + + + MEDIUM_ALERT_SUBTEST: ------------------------------------------------------ + + declare + Medium_Alarm : C3900052.Medium_Alert_Type; -- Priv. ext. of extension. + use C3900052; -- Primitive operations of extension directly visible. + begin + if not Initial_Values_Okay (Medium_Alarm) then + Report.Failed ("Wrong initial values for Medium_Alert_Type"); + end if; + + Handle (Medium_Alarm); + + if Bad_Final_Values (Medium_Alarm) then + Report.Failed ("Wrong values for Medium_Alert_Type after Handle"); + end if; + end Medium_Alert_Subtest; + + + -- Check final display counts: + + if C3900050.Display_Count_For /= (Null_Device => 3, + Teletype => 2, + Console => 1, + Big_Screen => 0) + then + Report.Failed ("Wrong display counts after Medium_Alert_Type"); + end if; + + + Report.Result; + +end C3900053; diff --git a/gcc-4.9/gcc/testsuite/ada/acats/tests/c3/c3900060.a b/gcc-4.9/gcc/testsuite/ada/acats/tests/c3/c3900060.a new file mode 100644 index 000000000..b77219c57 --- /dev/null +++ b/gcc-4.9/gcc/testsuite/ada/acats/tests/c3/c3900060.a @@ -0,0 +1,159 @@ +-- C3900060.A +-- +-- Grant of Unlimited Rights +-- +-- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687, +-- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained +-- unlimited rights in the software and documentation contained herein. +-- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making +-- this public release, the Government intends to confer upon all +-- recipients unlimited rights equal to those held by the Government. +-- These rights include rights to use, duplicate, release or disclose the +-- released technical data and computer software in whole or in part, in +-- any manner and for any purpose whatsoever, and to have or permit others +-- to do so. +-- +-- DISCLAIMER +-- +-- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR +-- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED +-- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE +-- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE +-- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A +-- PARTICULAR PURPOSE OF SAID MATERIAL. +--* +-- +-- OBJECTIVE: +-- See C3900063.AM. +-- +-- TEST DESCRIPTION: +-- See C3900063.AM. +-- +-- TEST FILES: +-- This test consists of the following files: +-- +-- => C3900060.A +-- C3900061.A +-- C3900062.A +-- C3900063.AM +-- +-- +-- CHANGE HISTORY: +-- 06 Dec 94 SAIC ACVC 2.0 +-- 04 Jun 96 SAIC ACVC 2.1: Modified prologue. Added pragma Elaborate +-- for Ada.Calendar. +-- +--! + +with Ada.Calendar; +pragma Elaborate (Ada.Calendar); + +package C3900060 is -- Alert system abstraction. + + + -- Declarations used by component Arrival_Time. + + Default_Time : constant Ada.Calendar.Time := + Ada.Calendar.Time_Of (1901, 1, 1); + Alert_Time : constant Ada.Calendar.Time := + Ada.Calendar.Time_Of (1991, 6, 15); + + + -- Declarations used by component Display_On and procedure Display. + + type Device_Enum is (Null_Device, Teletype, Console, Big_Screen); + type Display_Counters is array (Device_Enum) of Natural; + + Display_Count_For : Display_Counters := (others => 0); + + + + type Alert_Type is tagged private; -- Root tagged type. + + procedure Set_Display (A : in out Alert_Type; -- To be inherited by + D : in Device_Enum); -- all derivatives. + + procedure Display (A : in Alert_Type); -- To be inherited by + -- all derivatives. + + procedure Handle (A : in out Alert_Type); -- To be overridden by + -- all derivatives. + + + -- The following functions are needed to verify the values of the + -- root tagged type's private components. + + function Get_Time (A: Alert_Type) return Ada.Calendar.Time; + + function Get_Display (A: Alert_Type) return Device_Enum; + + function Initial_Values_Okay (A : in Alert_Type) + return Boolean; + + function Bad_Final_Values (A : in Alert_Type) + return Boolean; + +private + + type Alert_Type is tagged record -- Root tagged type. + Arrival_Time : Ada.Calendar.Time := Default_Time; + Display_On : Device_Enum := Null_Device; + end record; + + +end C3900060; + + + --==================================================================-- + + +package body C3900060 is + + + procedure Set_Display (A : in out Alert_Type; + D : in Device_Enum) is + begin + A.Display_On := D; + end Set_Display; + + + procedure Display (A : in Alert_Type) is + begin + Display_Count_For (A.Display_On) := Display_Count_For (A.Display_On) + 1; + end Display; + + + procedure Handle (A : in out Alert_Type) is + begin + A.Arrival_Time := Alert_Time; + Display (A); + end Handle; + + + function Get_Time (A: Alert_Type) return Ada.Calendar.Time is + begin + return A.Arrival_Time; + end Get_Time; + + + function Get_Display (A: Alert_Type) return Device_Enum is + begin + return A.Display_On; + end Get_Display; + + + function Initial_Values_Okay (A : in Alert_Type) return Boolean is + begin + return (A = (Arrival_Time => Default_Time, -- Check "=" operator + Display_On => Null_Device)); -- availability. + end Initial_Values_Okay; -- Aggregate with + -- named associations. + + function Bad_Final_Values (A : in Alert_Type) return Boolean is + begin + return (A /= (Alert_Time, Null_Device)); -- Check "/=" operator + -- availability. + end Bad_Final_Values; -- Aggregate with + -- positional assoc. + +end C3900060; diff --git a/gcc-4.9/gcc/testsuite/ada/acats/tests/c3/c3900061.a b/gcc-4.9/gcc/testsuite/ada/acats/tests/c3/c3900061.a new file mode 100644 index 000000000..f776dcdb8 --- /dev/null +++ b/gcc-4.9/gcc/testsuite/ada/acats/tests/c3/c3900061.a @@ -0,0 +1,138 @@ +-- C3900061.A +-- +-- Grant of Unlimited Rights +-- +-- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687, +-- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained +-- unlimited rights in the software and documentation contained herein. +-- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making +-- this public release, the Government intends to confer upon all +-- recipients unlimited rights equal to those held by the Government. +-- These rights include rights to use, duplicate, release or disclose the +-- released technical data and computer software in whole or in part, in +-- any manner and for any purpose whatsoever, and to have or permit others +-- to do so. +-- +-- DISCLAIMER +-- +-- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR +-- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED +-- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE +-- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE +-- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A +-- PARTICULAR PURPOSE OF SAID MATERIAL. +--* +-- +-- OBJECTIVE: +-- See C3900063.AM. +-- +-- TEST DESCRIPTION: +-- See C3900063.AM. +-- +-- TEST FILES: +-- This test consists of the following files: +-- +-- C3900060.A +-- => C3900061.A +-- C3900062.A +-- C3900063.AM +-- +-- +-- CHANGE HISTORY: +-- 06 Dec 94 SAIC ACVC 2.0 +-- 04 Jun 96 SAIC ACVC 2.1: Modified prologue. Added pragma Elaborate +-- for Ada.Calendar. +-- +--! + +with C3900060; -- Alert system abstraction. +package C3900061 is -- Extended alert abstraction. + + + type Low_Alert_Type is new C3900060.Alert_Type + with private; -- Private extension of + -- root tagged type. + + -- Inherits procedure Display from Alert_Type. + + procedure Handle (LA : in out Low_Alert_Type); -- Override parent's + -- primitive subprog. + + procedure Set_Level (LA : in out Low_Alert_Type; -- To be inherited by + L : in Integer); -- all derivatives. + + + -- The following functions are needed to verify the values of the + -- extension's private components. + + function Get_Level (LA: Low_Alert_Type) return Integer; + + function Initial_Values_Okay (LA : in Low_Alert_Type) + return Boolean; -- Override parent's + -- primitive subprog. + + function Bad_Final_Values (LA : in Low_Alert_Type) -- Override parent's + return Boolean; -- primitive subprog. + + +private + + type Low_Alert_Type is new C3900060.Alert_Type with record + Level : Integer := 0; + end record; + +end C3900061; + + + --==================================================================-- + + +with Ada.Calendar; +pragma Elaborate (Ada.Calendar); + +package body C3900061 is + + use C3900060; -- Alert system abstraction. + + + procedure Set_Level (LA : in out Low_Alert_Type; + L : in Integer) is + begin + LA.Level := L; + end Set_Level; + + + procedure Handle (LA : in out Low_Alert_Type) is + begin + Handle (Alert_Type (LA)); -- Call parent's operation (type conversion). + Set_Level (LA, 1); -- Call newly declared operation. + Set_Display (Alert_Type(LA), + Teletype); -- Call parent's operation (type conversion). + Display (LA); -- Call inherited operation. + end Handle; + + + function Get_Level (LA: Low_Alert_Type) return Integer is + begin + return LA.Level; + end Get_Level; + + + function Initial_Values_Okay (LA : in Low_Alert_Type) return Boolean is + begin + -- Call parent's operation (type conversion). + return (Initial_Values_Okay (Alert_Type (LA)) and + LA.Level = 0); + end Initial_Values_Okay; + + + function Bad_Final_Values (LA : in Low_Alert_Type) return Boolean is + use type Ada.Calendar.Time; + begin + return (Get_Time(LA) /= Alert_Time or + Get_Display(LA) /= Teletype or + LA.Level /= 1); + end Bad_Final_Values; + + +end C3900061; diff --git a/gcc-4.9/gcc/testsuite/ada/acats/tests/c3/c3900062.a b/gcc-4.9/gcc/testsuite/ada/acats/tests/c3/c3900062.a new file mode 100644 index 000000000..87a1cd5a3 --- /dev/null +++ b/gcc-4.9/gcc/testsuite/ada/acats/tests/c3/c3900062.a @@ -0,0 +1,137 @@ +-- C3900062.A +-- +-- Grant of Unlimited Rights +-- +-- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687, +-- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained +-- unlimited rights in the software and documentation contained herein. +-- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making +-- this public release, the Government intends to confer upon all +-- recipients unlimited rights equal to those held by the Government. +-- These rights include rights to use, duplicate, release or disclose the +-- released technical data and computer software in whole or in part, in +-- any manner and for any purpose whatsoever, and to have or permit others +-- to do so. +-- +-- DISCLAIMER +-- +-- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR +-- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED +-- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE +-- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE +-- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A +-- PARTICULAR PURPOSE OF SAID MATERIAL. +--* +-- +-- OBJECTIVE: +-- See C3900063.AM. +-- +-- TEST DESCRIPTION: +-- See C3900063.AM. +-- +-- TEST FILES: +-- This test consists of the following files: +-- +-- C3900060.A +-- C3900061.A +-- => C3900062.A +-- C3900063.AM +-- +-- +-- CHANGE HISTORY: +-- 06 Dec 94 SAIC ACVC 2.0 +-- 04 Jun 96 SAIC ACVC 2.1: Modified prologue. Added pragma Elaborate +-- for Ada.Calendar. +-- +--! + +with C3900061; -- Extended alert system abstraction. +package C3900062 is -- Further extended alert system abstraction. + + + -- Declarations used by component Action_Officer; + + type Person_Enum is (Nobody, Duty_Officer, + Watch_Commander, Commanding_Officer); + + + type Medium_Alert_Type is new C3900061.Low_Alert_Type + with record -- Record extension of + Action_Officer : Person_Enum := Nobody; -- private extension. + end record; + + + -- Inherits (inherited) procedure Display from Low_Alert_Type. + -- Inherits function Level_Of from Low_Alert_Type. + + procedure Handle (MA : in out Medium_Alert_Type); -- Override parent's + -- primitive subprog. + + procedure Assign_Officer (MA : in out Medium_Alert_Type; + To : in Person_Enum); + + + -- The following functions are needed to verify the values of the + -- extension's private components. + + function Initial_Values_Okay (MA : in Medium_Alert_Type) + return Boolean; -- Override parent's + -- primitive subprog. + + function Bad_Final_Values (MA: in Medium_Alert_Type) -- Override parent's + return Boolean; -- primitive subprog. + + +end C3900062; + + + --==================================================================-- + + +with C3900060; -- Basic alert abstraction. + +with Ada.Calendar; +pragma Elaborate (Ada.Calendar); + +package body C3900062 is + + use C3900060; -- Enumeration values directly visible. + use C3900061; -- Extended alert system abstraction. + + + procedure Assign_Officer (MA : in out Medium_Alert_Type; + To : in Person_Enum) is + begin + MA.Action_Officer := To; + end Assign_Officer; + + + procedure Handle (MA : in out Medium_Alert_Type) is + begin + Handle (Low_Alert_Type (MA)); -- Call parent's op (type conversion). + Set_Level (MA, 2); -- Call inherited operation. + Assign_Officer (MA, Duty_Officer); -- Call newly declared operation. + Set_Display (MA, Console); -- Call inherited operation. + Display (MA); -- Call doubly inherited operation. + end Handle; + + + function Initial_Values_Okay (MA : in Medium_Alert_Type) return Boolean is + begin + -- Call parent's operation (type conversion). + return (Initial_Values_Okay (Low_Alert_Type (MA)) and + MA.Action_Officer = Nobody); + end Initial_Values_Okay; + + + function Bad_Final_Values (MA : in Medium_Alert_Type) return Boolean is + use type Ada.Calendar.Time; + begin + return (Get_Time(MA) /= Alert_Time or + Get_Display(MA) /= Console or + Get_Level(MA) /= 2 or + MA.Action_Officer /= Duty_Officer); + end Bad_Final_Values; + + +end C3900062; diff --git a/gcc-4.9/gcc/testsuite/ada/acats/tests/c3/c3900063.am b/gcc-4.9/gcc/testsuite/ada/acats/tests/c3/c3900063.am new file mode 100644 index 000000000..7d88719ad --- /dev/null +++ b/gcc-4.9/gcc/testsuite/ada/acats/tests/c3/c3900063.am @@ -0,0 +1,138 @@ +-- C3900063.AM +-- +-- Grant of Unlimited Rights +-- +-- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687, +-- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained +-- unlimited rights in the software and documentation contained herein. +-- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making +-- this public release, the Government intends to confer upon all +-- recipients unlimited rights equal to those held by the Government. +-- These rights include rights to use, duplicate, release or disclose the +-- released technical data and computer software in whole or in part, in +-- any manner and for any purpose whatsoever, and to have or permit others +-- to do so. +-- +-- DISCLAIMER +-- +-- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR +-- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED +-- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE +-- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE +-- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A +-- PARTICULAR PURPOSE OF SAID MATERIAL. +--* +-- +-- OBJECTIVE: +-- Check that a private tagged type declared in a package specification +-- may be extended with a private extension in a different package +-- specification, and that this private extension may in turn be extended +-- by a record extension in a third package. +-- +-- Check that each derivative inherits the user-defined primitive +-- subprograms of its parent (including those that its parent inherited), +-- that it may override these inherited primitive subprograms, and that it +-- may also declare its own primitive subprograms. +-- +-- Check that type conversion is defined from a type extension to its +-- parent, and that this parent itself may be a type extension. +-- +-- TEST DESCRIPTION: +-- Declare a root tagged private type and two associated primitive +-- subprograms in a package specification. Declare operations to verify +-- the correctness of the components. Declare operations which return +-- values of the type's private components, and which will be inherited +-- by later derivatives. +-- +-- Extend the root type with a private extension in a second package +-- specification. Declare a new primitive subprogram for the extension, +-- and override one of the two inherited subprograms. Within the +-- overriding subprogram, utilize type conversion to call the parent's +-- implementation of the same subprogram. Also within the overriding +-- subprogram, call the new primitive subprogram and each inherited +-- subprogram. Declare operations of the private extension which +-- override the verification operations of its parent. Declare +-- operations which return values of the extension's private components, +-- and which will be inherited by later derivatives. +-- +-- Extend the extension with a record extension in a third package +-- specification. Declare a new primitive subprogram for this record +-- extension, and override one of the three inherited subprograms. +-- Within the overriding subprogram, utilize type conversion to call the +-- parent's implementation of the same subprogram. Also within the +-- overriding subprogram, call the new primitive subprogram and each +-- inherited subprogram. Declare operations of the record extension +-- which override the verification operations of its parent. +-- +-- In the main program, declare objects of the root tagged type and +-- the two type extensions. For each object, call the overriding +-- subprogram, and verify the correctness of the components by calling +-- the verification operations. +-- +-- TEST FILES: +-- This test consists of the following files: +-- +-- C3900060.A +-- C3900061.A +-- C3900062.A +-- => C3900063.AM +-- +-- +-- CHANGE HISTORY: +-- 06 Dec 94 SAIC ACVC 2.0 +-- 04 Jun 96 SAIC ACVC 2.1: Modified prologue. +-- +--! + +with Report; + +with C3900060; -- Basic alert abstraction. +with C3900062; -- Further extended alert abstraction. + +use C3900060; -- Primitive operations of Alert_Type directly visible. + +procedure C3900063 is +begin + + Report.Test ("C390006", "Primitive operation inheritance by type " & + "extensions: all extensions declared in different " & + "packages; root type and 1st extension are private, " & + "2nd extension is record extension"); + + + -- The cases for type C3900060.Alert_Type and C3900061.Low_Alert_Type + -- are tested in C390005. Those subtests are not repeated here. + + + MEDIUM_ALERT_SUBTEST: ------------------------------------------------------ + + declare + Medium_Alarm : C3900062.Medium_Alert_Type; -- Rec. ext. of extension. + use C3900062; -- Primitive operations of extension directly visible. + begin + if not Initial_Values_Okay (Medium_Alarm) then + Report.Failed ("Wrong initial values for Medium_Alert_Type"); + end if; + + Handle (Medium_Alarm); + + if Bad_Final_Values (Medium_Alarm) then + Report.Failed ("Wrong values for Medium_Alert_Type after Handle"); + end if; + end Medium_Alert_Subtest; + + + -- Check final display counts: + + if C3900060.Display_Count_For /= (Null_Device => 1, + Teletype => 1, + Console => 1, + Big_Screen => 0) + then + Report.Failed ("Wrong display counts after Medium_Alert_Type"); + end if; + + + Report.Result; + +end C3900063; diff --git a/gcc-4.9/gcc/testsuite/ada/acats/tests/c3/c390007.a b/gcc-4.9/gcc/testsuite/ada/acats/tests/c3/c390007.a new file mode 100644 index 000000000..46f59f66c --- /dev/null +++ b/gcc-4.9/gcc/testsuite/ada/acats/tests/c3/c390007.a @@ -0,0 +1,374 @@ +-- C390007.A +-- +-- Grant of Unlimited Rights +-- +-- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687, +-- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained +-- unlimited rights in the software and documentation contained herein. +-- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making +-- this public release, the Government intends to confer upon all +-- recipients unlimited rights equal to those held by the Government. +-- These rights include rights to use, duplicate, release or disclose the +-- released technical data and computer software in whole or in part, in +-- any manner and for any purpose whatsoever, and to have or permit others +-- to do so. +-- +-- DISCLAIMER +-- +-- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR +-- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED +-- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE +-- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE +-- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A +-- PARTICULAR PURPOSE OF SAID MATERIAL. +--* +-- +-- OBJECTIVE: +-- Check that the tag of an object of a tagged type is preserved by +-- type conversion and parameter passing. +-- +-- TEST DESCRIPTION: +-- The fact that the tag of an object is not changed is verified by +-- making dispatching calls to primitive operations, and confirming that +-- the proper body is executed. Objects of both specific and class-wide +-- types are checked. +-- +-- The dispatching calls are made in two contexts. The first is a +-- straightforward dispatching call made from within a class-wide +-- operation. The second is a redispatch from within a primitive +-- operation. +-- +-- For the parameter passing case, the initial class-wide and specific +-- objects are passed directly in calls to the class-wide and primitive +-- operations. The redispatch is accomplished by initializing a local +-- class-wide object in the primitive operation to the value of the +-- formal parameter, and using the local object as the actual in the +-- (re)dispatching call. +-- +-- For the type conversion case, the initial class-wide object is assigned +-- a view conversion of an object of a specific type: +-- +-- type T is tagged ... +-- type DT is new T with ... +-- +-- A : DT; +-- B : T'Class := T(A); -- Despite conversion, tag of B is that of DT. +-- +-- The class-wide object is then passed directly in calls to the +-- class-wide and primitive operations. For the initial object of a +-- specific type, however, a view conversion of the object is passed, +-- forcing a non-dispatching call in the primitive operation case. Within +-- the primitive operation, a view conversion of the formal parameter to +-- a class-wide type is then used to force a (re)dispatching call. +-- +-- For the type conversion and parameter passing case, a combining of +-- view conversion and parameter passing of initial specific objects are +-- called directly to the class-wide and primitive operations. +-- +-- +-- CHANGE HISTORY: +-- 28 Jun 95 SAIC Initial prerelease version. +-- 23 Apr 96 SAIC Added use C390007_0 in the main. +-- +--! + +package C390007_0 is + + type Call_ID_Kind is (None, Parent_Outer, Parent_Inner, + Derived_Outer, Derived_Inner); + + type Root_Type is abstract tagged null record; + + procedure Outer_Proc (X : in out Root_Type) is abstract; + procedure Inner_Proc (X : in out Root_Type) is abstract; + + procedure ClassWide_Proc (X : in out Root_Type'Class); + +end C390007_0; + + + --==================================================================-- + + +package body C390007_0 is + + procedure ClassWide_Proc (X : in out Root_Type'Class) is + begin + Inner_Proc (X); + end ClassWide_Proc; + +end C390007_0; + + + --==================================================================-- + + +package C390007_0.C390007_1 is + + type Param_Parent_Type is new Root_Type with record + Last_Call : Call_ID_Kind := None; + end record; + + procedure Outer_Proc (X : in out Param_Parent_Type); + procedure Inner_Proc (X : in out Param_Parent_Type); + +end C390007_0.C390007_1; + + + --==================================================================-- + + +package body C390007_0.C390007_1 is + + procedure Outer_Proc (X : in out Param_Parent_Type) is + begin + X.Last_Call := Parent_Outer; + end Outer_Proc; + + procedure Inner_Proc (X : in out Param_Parent_Type) is + begin + X.Last_Call := Parent_Inner; + end Inner_Proc; + +end C390007_0.C390007_1; + + + --==================================================================-- + + +package C390007_0.C390007_1.C390007_2 is + + type Param_Derived_Type is new Param_Parent_Type with null record; + + procedure Outer_Proc (X : in out Param_Derived_Type); + procedure Inner_Proc (X : in out Param_Derived_Type); + +end C390007_0.C390007_1.C390007_2; + + + --==================================================================-- + + +package body C390007_0.C390007_1.C390007_2 is + + procedure Outer_Proc (X : in out Param_Derived_Type) is + Y : Root_Type'Class := X; + begin + Inner_Proc (Y); -- Redispatch. + Root_Type'Class (X) := Y; + end Outer_Proc; + + procedure Inner_Proc (X : in out Param_Derived_Type) is + begin + X.Last_Call := Derived_Inner; + end Inner_Proc; + +end C390007_0.C390007_1.C390007_2; + + + --==================================================================-- + + +package C390007_0.C390007_3 is + + type Convert_Parent_Type is new Root_Type with record + First_Call : Call_ID_Kind := None; + Second_Call : Call_ID_Kind := None; + end record; + + procedure Outer_Proc (X : in out Convert_Parent_Type); + procedure Inner_Proc (X : in out Convert_Parent_Type); + +end C390007_0.C390007_3; + + + --==================================================================-- + + +package body C390007_0.C390007_3 is + + procedure Outer_Proc (X : in out Convert_Parent_Type) is + begin + X.First_Call := Parent_Outer; + Inner_Proc (Root_Type'Class(X)); -- Redispatch. + end Outer_Proc; + + procedure Inner_Proc (X : in out Convert_Parent_Type) is + begin + X.Second_Call := Parent_Inner; + end Inner_Proc; + +end C390007_0.C390007_3; + + + --==================================================================-- + + +package C390007_0.C390007_3.C390007_4 is + + type Convert_Derived_Type is new Convert_Parent_Type with null record; + + procedure Outer_Proc (X : in out Convert_Derived_Type); + procedure Inner_Proc (X : in out Convert_Derived_Type); + +end C390007_0.C390007_3.C390007_4; + + + --==================================================================-- + + +package body C390007_0.C390007_3.C390007_4 is + + procedure Outer_Proc (X : in out Convert_Derived_Type) is + begin + X.First_Call := Derived_Outer; + Inner_Proc (Root_Type'Class(X)); -- Redispatch. + end Outer_Proc; + + procedure Inner_Proc (X : in out Convert_Derived_Type) is + begin + X.Second_Call := Derived_Inner; + end Inner_Proc; + +end C390007_0.C390007_3.C390007_4; + + + --==================================================================-- + + +with C390007_0.C390007_1.C390007_2; +with C390007_0.C390007_3.C390007_4; +use C390007_0; + +with Report; +procedure C390007 is +begin + Report.Test ("C390007", "Check that the tag of an object of a tagged " & + "type is preserved by type conversion and parameter passing"); + + + -- + -- Check that tags are preserved by parameter passing: + -- + + Parameter_Passing_Subtest: + declare + Specific_A : C390007_0.C390007_1.C390007_2.Param_Derived_Type; + Specific_B : C390007_0.C390007_1.C390007_2.Param_Derived_Type; + + ClassWide_A : C390007_0.C390007_1.Param_Parent_Type'Class := Specific_A; + ClassWide_B : C390007_0.C390007_1.Param_Parent_Type'Class := Specific_B; + + use C390007_0.C390007_1; + use C390007_0.C390007_1.C390007_2; + begin + + Outer_Proc (Specific_A); + if Specific_A.Last_Call /= Derived_Inner then + Report.Failed ("Parameter passing: tag not preserved in call to " & + "primitive operation with specific operand"); + end if; + + C390007_0.ClassWide_Proc (Specific_B); + if Specific_B.Last_Call /= Derived_Inner then + Report.Failed ("Parameter passing: tag not preserved in call to " & + "class-wide operation with specific operand"); + end if; + + Outer_Proc (ClassWide_A); + if ClassWide_A.Last_Call /= Derived_Inner then + Report.Failed ("Parameter passing: tag not preserved in call to " & + "primitive operation with class-wide operand"); + end if; + + C390007_0.ClassWide_Proc (ClassWide_B); + if ClassWide_B.Last_Call /= Derived_Inner then + Report.Failed ("Parameter passing: tag not preserved in call to " & + "class-wide operation with class-wide operand"); + end if; + + end Parameter_Passing_Subtest; + + + -- + -- Check that tags are preserved by type conversion: + -- + + Type_Conversion_Subtest: + declare + Specific_A : C390007_0.C390007_3.C390007_4.Convert_Derived_Type; + Specific_B : C390007_0.C390007_3.C390007_4.Convert_Derived_Type; + + ClassWide_A : C390007_0.C390007_3.Convert_Parent_Type'Class := + C390007_0.C390007_3.Convert_Parent_Type(Specific_A); + ClassWide_B : C390007_0.C390007_3.Convert_Parent_Type'Class := + C390007_0.C390007_3.Convert_Parent_Type(Specific_B); + + use C390007_0.C390007_3; + use C390007_0.C390007_3.C390007_4; + begin + + Outer_Proc (Convert_Parent_Type(Specific_A)); + if (Specific_A.First_Call /= Parent_Outer) or + (Specific_A.Second_Call /= Derived_Inner) + then + Report.Failed ("Type conversion: tag not preserved in call to " & + "primitive operation with specific operand"); + end if; + + Outer_Proc (ClassWide_A); + if (ClassWide_A.First_Call /= Derived_Outer) or + (ClassWide_A.Second_Call /= Derived_Inner) + then + Report.Failed ("Type conversion: tag not preserved in call to " & + "primitive operation with class-wide operand"); + end if; + + C390007_0.ClassWide_Proc (Convert_Parent_Type(Specific_B)); + if (Specific_B.Second_Call /= Derived_Inner) then + Report.Failed ("Type conversion: tag not preserved in call to " & + "class-wide operation with specific operand"); + end if; + + C390007_0.ClassWide_Proc (ClassWide_B); + if (ClassWide_A.Second_Call /= Derived_Inner) then + Report.Failed ("Type conversion: tag not preserved in call to " & + "class-wide operation with class-wide operand"); + end if; + + end Type_Conversion_Subtest; + + + -- + -- Check that tags are preserved by type conversion and parameter passing: + -- + + Type_Conversion_And_Parameter_Passing_Subtest: + declare + Specific_A : C390007_0.C390007_1.C390007_2.Param_Derived_Type; + Specific_B : C390007_0.C390007_1.C390007_2.Param_Derived_Type; + + use C390007_0.C390007_1; + use C390007_0.C390007_1.C390007_2; + begin + + Outer_Proc (Param_Parent_Type (Specific_A)); + if Specific_A.Last_Call /= Parent_Outer then + Report.Failed ("Type conversion and parameter passing: tag not " & + "preserved in call to primitive operation with " & + "specific operand"); + end if; + + C390007_0.ClassWide_Proc (Param_Parent_Type (Specific_B)); + if Specific_B.Last_Call /= Derived_Inner then + Report.Failed ("Type conversion and parameter passing: tag not " & + "preserved in call to class-wide operation with " & + "specific operand"); + end if; + + end Type_Conversion_And_Parameter_Passing_Subtest; + + + Report.Result; + +end C390007; diff --git a/gcc-4.9/gcc/testsuite/ada/acats/tests/c3/c390010.a b/gcc-4.9/gcc/testsuite/ada/acats/tests/c3/c390010.a new file mode 100644 index 000000000..1590e5027 --- /dev/null +++ b/gcc-4.9/gcc/testsuite/ada/acats/tests/c3/c390010.a @@ -0,0 +1,216 @@ +-- C390010.A +-- +-- Grant of Unlimited Rights +-- +-- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687, +-- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained +-- unlimited rights in the software and documentation contained herein. +-- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making +-- this public release, the Government intends to confer upon all +-- recipients unlimited rights equal to those held by the Government. +-- These rights include rights to use, duplicate, release or disclose the +-- released technical data and computer software in whole or in part, in +-- any manner and for any purpose whatsoever, and to have or permit others +-- to do so. +-- +-- DISCLAIMER +-- +-- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR +-- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED +-- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE +-- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE +-- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A +-- PARTICULAR PURPOSE OF SAID MATERIAL. +--* +-- +-- OBJECTIVE: +-- Check that if S is a subtype of a tagged type T, and if S is +-- constrained, then the allowable values of S'Class are only those +-- that, when converted to T, belong to S. +-- +-- TEST DESCRIPTION: +-- This test defines a small tagged hierarchy of discriminated tagged +-- records, and constrained subtypes of those tagged record types. +-- It then uses access to the classwide of the constrained subtype +-- to check the objective. +-- +-- +-- CHANGE HISTORY: +-- 09 APR 96 SAIC Initial version +-- 03 NOV 96 SAIC Revised for 2.1 release +-- 31 DEC 97 EDS Restored use of intermediate access variable +-- to eliminate raising of Program_Error +-- 13 SEP 99 RLB Repaired previous change to avoid premature +-- subtype check. +-- 28 JUN 02 RLB Added pragma Elaborate_All (Report);. +--! + +----------------------------------------------------------------- C390010_0 + +with Report; pragma Elaborate_All (Report); +package C390010_0 is + + -- the defined subprograms will allow checking the placement of + -- constraint_checks + + -- define a discriminated tagged type, and a constrained subtype of + -- that type: + + type Discr_Tag_Record( Disc: Boolean ) is tagged record + FieldA : Character := 'A'; + case Disc is + when True => FieldB : Character := 'B'; + when False => FieldC : Character := 'C'; + end case; + end record; + + procedure Dispatching_Op( DTO : in out Discr_Tag_Record ); + + Authentic : Boolean := Report.Ident_Bool( True ); + + subtype True_Record is Discr_Tag_Record( Authentic ); + + + -- derive a type, "passing through" one discriminant, adding one + -- discriminant, and a constrained subtype of THAT type: + + type Derived_Record( Disc1, Disc2: Boolean ) is + new Discr_Tag_Record( Disc1 ) with record + FieldD : Character := 'D'; + case Disc2 is + when True => FieldE : Character := 'E'; + when False => FieldF : Character := 'F'; + end case; + end record; + + procedure Dispatching_Op( DR : in out Derived_Record ); + + subtype True_True_Derived is Derived_Record( Authentic, Authentic ); + + + -- now, define an access to classwide type, using the classwide from the + -- constrained subtype of the root (or parent) type: + + type Subtype_Parent_Class_Access is access all True_Record'Class; + type Parent_Class_Access is access all Discr_Tag_Record'Class; + + procedure PCW_Op( SPCA : in Subtype_Parent_Class_Access ); + +end C390010_0; + +-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- C390010_0 + +with Report; +with TCTouch; +package body C390010_0 is + + procedure Dispatching_Op( DTO : in out Discr_Tag_Record ) is + begin + TCTouch.Touch('1'); --------------------------------------------------- 1 + if DTO.Disc then + TCTouch.Touch(DTO.FieldB); ------------------------------------------ B + else + TCTouch.Touch(DTO.FieldC); ------------------------------------------ C + end if; + end Dispatching_Op; + + + procedure Dispatching_Op( DR : in out Derived_Record ) is + begin + TCTouch.Touch('2'); --------------------------------------------------- 2 + if DR.Disc1 then + TCTouch.Touch(DR.FieldB); ------------------------------------------ B + else + TCTouch.Touch(DR.FieldC); ------------------------------------------ C + end if; + if DR.Disc2 then + TCTouch.Touch(DR.FieldE); ------------------------------------------ E + else + TCTouch.Touch(DR.FieldF); ------------------------------------------ F + end if; + end Dispatching_Op; + + procedure PCW_Op( SPCA : in Subtype_Parent_Class_Access ) is + begin + + -- the following line is the "heart" of this test, objects of all types + -- covered by the classwide type will be passed to this subprogram in + -- the execution of the test. + if SPCA.Disc then + TCTouch.Touch(SPCA.FieldB); ------------------------------------------ B + else + TCTouch.Touch(SPCA.FieldC); ------------------------------------------ C + end if; + + Dispatching_Op( SPCA.all ); -- check that this dispatches correctly, + -- with discriminants correctly represented + + end PCW_Op; + +end C390010_0; + +------------------------------------------------------------------- C390010 + +with Report; +with TCTouch; +with C390010_0; +procedure C390010 is + + package CP renames C390010_0; + + procedure Check_Element( Item : access CP.Discr_Tag_Record'Class ) is + begin + + -- the implicit conversion from the general access parameter to the more + -- constrained subtype access type in the following call should cause + -- Constraint_Error in the cases where the object is not correctly + -- constrained + + CP.PCW_Op( Item.all'Access ); + + exception + when Constraint_Error => TCTouch.Touch('X'); -------------------------- X + when others => Report.Failed("Unanticipated exception in Check_Element"); + + end Check_Element; + + An_Item : CP.Parent_Class_Access; + +begin -- Main test procedure. + + Report.Test ("C390010", "Check that if S is a subtype of a tagged type " & + "T, and if S is constrained, then the allowable " & + "values of S'Class are only those that, when " & + "converted to T, belong to S" ); + + An_Item := new CP.Discr_Tag_Record(True); + Check_Element( An_Item ); + TCTouch.Validate("B1B","Case 1"); + + An_Item := new CP.Discr_Tag_Record(False); + Check_Element( An_Item ); + TCTouch.Validate("X","Case 2"); + + An_Item := new CP.True_Record; + Check_Element( An_Item ); + TCTouch.Validate("B1B","Case 3"); + + An_Item := new CP.Derived_Record(False, False); + Check_Element( An_Item ); + TCTouch.Validate("X","Case 4"); + + An_Item := new CP.Derived_Record(False, True); + Check_Element( An_Item ); + TCTouch.Validate("X","Case 5"); + + An_Item := new CP.Derived_Record(True, False); + Check_Element( An_Item ); + TCTouch.Validate("B2BF","Case 6"); + + An_Item := new CP.True_True_Derived; + Check_Element( An_Item ); + TCTouch.Validate("B2BE","Case 7"); + + Report.Result; + +end C390010; diff --git a/gcc-4.9/gcc/testsuite/ada/acats/tests/c3/c390011.a b/gcc-4.9/gcc/testsuite/ada/acats/tests/c3/c390011.a new file mode 100644 index 000000000..74cf0eb04 --- /dev/null +++ b/gcc-4.9/gcc/testsuite/ada/acats/tests/c3/c390011.a @@ -0,0 +1,250 @@ +-- C390011.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 tagged types declared within generic package declarations +-- generate distinct tags for each instance of the generic. +-- +-- TEST DESCRIPTION: +-- This test defines a very simple generic package (with the expectation +-- that it should be easily be shared), and a few instances of that +-- package. In true user-like fashion, two of the instances are identical +-- (to wit: IIO is new Integer_IO(Integer)). The tags generated for each +-- of them are placed into a list. The last action of the test is to +-- check that everything in the list is unique. +-- +-- Almost as an aside, this test defines functions that return T'Base and +-- T'Class, and then exercises these functions. +-- +-- (JPR) persistent objects really need a function like: +-- function Get_Object return T'class; +-- +-- +-- CHANGE HISTORY: +-- 20 OCT 95 SAIC Initial version +-- 23 APR 96 SAIC Commentary Corrections 2.1 +-- +--! + +----------------------------------------------------------------- C390011_0 + +with Ada.Tags; +package C390011_0 is + + procedure Add_Tag_To_List( T : Ada.Tags.Tag; X_Name, X_Tag: String ); + + procedure Check_List_For_Duplicates; + +end C390011_0; + +-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- + +with Report; +package body C390011_0 is + + use type Ada.Tags.Tag; + type SP is access String; + + type List_Item; + type List_P is access List_Item; + type List_Item is record + The_Tag : Ada.Tags.Tag; + Exp_Name : SP; + Ext_Tag : SP; + Next : List_P; + end record; + + The_List : List_P; + + procedure Add_Tag_To_List ( T : Ada.Tags.Tag; X_Name, X_Tag: String ) is + begin -- prepend the tag information to the list + The_List := new List_Item'( The_Tag => T, + Exp_Name => new String'(X_Name), + Ext_Tag => new String'(X_Tag), + Next => The_List ); + end Add_Tag_To_List; + + procedure Check_List_For_Duplicates is + Finger : List_P; + Thumb : List_P := The_List; + begin -- + while Thumb /= null loop + Finger := Thumb.Next; + while Finger /= null loop + -- Check that the tag is unique + if Finger.The_Tag = Thumb.The_Tag then + Report.Failed("Duplicate Tag"); + end if; + + -- Check that the Expanded name is unique + if Finger.Exp_Name.all = Thumb.Exp_Name.all then + Report.Failed("Tag name " & Finger.Exp_Name.all & " repeats"); + end if; + + -- Check that the External Tag is unique + + if Finger.Ext_Tag.all = Thumb.Ext_Tag.all then + Report.Failed("External Tag " & Finger.Ext_Tag.all & " repeats"); + end if; + Finger := Finger.Next; + end loop; + Thumb := Thumb.Next; + end loop; + end Check_List_For_Duplicates; + +begin + -- some things I just don't trust... + if The_List /= null then + Report.Failed("Implicit default for The_List not null"); + end if; +end C390011_0; + +----------------------------------------------------------------- C390011_1 + +generic + type Index is (<>); + type Item is private; +package C390011_1 is + + type List is array(Index range <>) of Item; + type ListP is access all List; + + type Table is tagged record + Data: ListP; + end record; + + function Sort( T: in Table'Class ) return Table'Class; + + function Stable_Table return Table'Class; + + function Table_End( T: Table ) return Index'Base; + +end C390011_1; + +-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- + +package body C390011_1 is + + -- In a user program this package would DO something + + function Sort( T: in Table'Class ) return Table'Class is + begin + return T; + end Sort; + + Empty : Table'Class := Table'( Data => null ); + + function Stable_Table return Table'Class is + begin + return Empty; + end Stable_Table; + + function Table_End( T: Table ) return Index'Base is + begin + return Index'Base( T.Data.all'Last ); + end Table_End; + +end C390011_1; + +----------------------------------------------------------------- C390011_2 + +with C390011_1; +package C390011_2 is new C390011_1( Index => Character, Item => Float ); + +----------------------------------------------------------------- C390011_3 + +with C390011_1; +package C390011_3 is new C390011_1( Index => Character, Item => Float ); + +----------------------------------------------------------------- C390011_4 + +with C390011_1; +package C390011_4 is new C390011_1( Index => Integer, Item => Character ); + +----------------------------------------------------------------- C390011_5 + +with C390011_3; +with C390011_4; +package C390011_5 is + + type Table_3 is new C390011_3.Table with record + Serial_Number : Integer; + end record; + + type Table_4 is new C390011_4.Table with record + Serial_Number : Integer; + end record; + +end C390011_5; + +-- no package body C390011_5 required + +------------------------------------------------------------------- C390011 + +with Report; +with C390011_0; +with C390011_2; +with C390011_3; +with C390011_4; +with C390011_5; +with Ada.Tags; +procedure C390011 is + +begin -- Main test procedure. + + Report.Test ("C390011", "Check that tagged types declared within " & + "generic package declarations generate distinct " & + "tags for each instance of the generic. " & + "Check that 'Base may be used as a subtype mark. " & + "Check that T'Base and T'Class are allowed as " & + "the subtype mark in a function result" ); + + -- build the tag information table + C390011_0.Add_Tag_To_List(T => C390011_2.Table'Tag, + X_Name => Ada.Tags.Expanded_Name(C390011_2.Table'Tag), + X_Tag => Ada.Tags.External_Tag(C390011_2.Table'Tag) ); + + C390011_0.Add_Tag_To_List(T => C390011_3.Table'Tag, + X_Name => Ada.Tags.Expanded_Name(C390011_3.Table'Tag), + X_Tag => Ada.Tags.External_Tag(C390011_3.Table'Tag) ); + + C390011_0.Add_Tag_To_List(T => C390011_4.Table'Tag, + X_Name => Ada.Tags.Expanded_Name(C390011_4.Table'Tag), + X_Tag => Ada.Tags.External_Tag(C390011_4.Table'Tag) ); + + C390011_0.Add_Tag_To_List(T => C390011_5.Table_3'Tag, + X_Name => Ada.Tags.Expanded_Name(C390011_5.Table_3'Tag), + X_Tag => Ada.Tags.External_Tag(C390011_5.Table_3'Tag) ); + + C390011_0.Add_Tag_To_List(T => C390011_5.Table_4'Tag, + X_Name => Ada.Tags.Expanded_Name(C390011_5.Table_4'Tag), + X_Tag => Ada.Tags.External_Tag(C390011_5.Table_4'Tag) ); + + -- preform the check for distinct tags + C390011_0.Check_List_For_Duplicates; + + Report.Result; + +end C390011; diff --git a/gcc-4.9/gcc/testsuite/ada/acats/tests/c3/c39006a.ada b/gcc-4.9/gcc/testsuite/ada/acats/tests/c3/c39006a.ada new file mode 100644 index 000000000..7e5f43dc0 --- /dev/null +++ b/gcc-4.9/gcc/testsuite/ada/acats/tests/c3/c39006a.ada @@ -0,0 +1,207 @@ +-- C39006A.ADA + +-- Grant of Unlimited Rights +-- +-- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687, +-- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained +-- unlimited rights in the software and documentation contained herein. +-- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making +-- this public release, the Government intends to confer upon all +-- recipients unlimited rights equal to those held by the Government. +-- These rights include rights to use, duplicate, release or disclose the +-- released technical data and computer software in whole or in part, in +-- any manner and for any purpose whatsoever, and to have or permit others +-- to do so. +-- +-- DISCLAIMER +-- +-- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR +-- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED +-- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF 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 PROGRAM_ERROR IS RAISED IF AN ATTEMPT IS MADE TO CALL A +-- SUBPROGRAM WHOSE BODY HAS NOT YET BEEN ELABORATED. CHECK THE +-- FOLLOWING: +-- A) A FUNCTION IS CALLED IN THE INITIALIZATION EXPRESSION OF A +-- SCALAR VARIABLE OR A RECORD COMPONENT, AND THE SCALAR OR +-- RECORD VARIABLE'S DECLARATION IS ELABORATED BEFORE THE +-- SUBPROGRAM BODY IS ELABORATED. + +-- TBN 8/14/86 + +WITH REPORT; USE REPORT; +PROCEDURE C39006A IS + +BEGIN + TEST ("C39006A", "CHECK THAT PROGRAM_ERROR IS RAISED IF AN " & + "ATTEMPT IS MADE TO CALL A SUBPROGRAM WHOSE " & + "BODY HAS NOT YET BEEN ELABORATED"); + BEGIN + DECLARE + + FUNCTION INIT_1 (A : INTEGER) RETURN INTEGER; + + VAR1 : INTEGER := INIT_1 (1); + + FUNCTION INIT_1 (A : INTEGER) RETURN INTEGER IS + BEGIN + RETURN (A + IDENT_INT(1)); + END INIT_1; + + BEGIN + FAILED ("PROGRAM_ERROR NOT RAISED - 1"); + END; + + EXCEPTION + WHEN PROGRAM_ERROR => + NULL; + WHEN OTHERS => + FAILED ("UNEXPECTED EXCEPTION RAISED - 1"); + END; + + BEGIN + DECLARE + + FUNCTION INIT_2 (A : INTEGER) RETURN INTEGER; + + TYPE REC1 IS + RECORD + NUMBER : INTEGER := INIT_2 (2); + END RECORD; + + VAR2 : REC1; + + FUNCTION INIT_2 (A : INTEGER) RETURN INTEGER IS + BEGIN + RETURN (A + IDENT_INT(1)); + END INIT_2; + + BEGIN + FAILED ("PROGRAM_ERROR NOT RAISED - 2"); + END; + + EXCEPTION + WHEN PROGRAM_ERROR => + NULL; + WHEN OTHERS => + FAILED ("UNEXPECTED EXCEPTION RAISED - 2"); + END; + + BEGIN + DECLARE + + FUNCTION F1 RETURN INTEGER; + + PACKAGE PACK IS + VAR1 : INTEGER := F1; + END PACK; + + FUNCTION F1 RETURN INTEGER IS + BEGIN + RETURN (IDENT_INT(1)); + END F1; + + BEGIN + FAILED ("PROGRAM_ERROR NOT RAISED - 3"); + END; + + EXCEPTION + WHEN PROGRAM_ERROR => + NULL; + WHEN OTHERS => + FAILED ("UNEXPECTED EXCEPTION RAISED - 3"); + END; + + BEGIN + DECLARE + + PACKAGE PACK IS + FUNCTION F2 RETURN INTEGER; + VAR2 : INTEGER := F2; + END PACK; + + PACKAGE BODY PACK IS + FUNCTION F2 RETURN INTEGER IS + BEGIN + RETURN (IDENT_INT(3)); + END F2; + END PACK; + + BEGIN + FAILED ("PROGRAM_ERROR NOT RAISED - 4"); + END; + + EXCEPTION + WHEN PROGRAM_ERROR => + NULL; + WHEN OTHERS => + FAILED ("UNEXPECTED EXCEPTION RAISED - 4"); + END; + + BEGIN + DECLARE + + FUNCTION INIT_3 (A : INTEGER) RETURN INTEGER; + + GENERIC + PACKAGE Q IS + VAR1 : INTEGER := INIT_3 (1); + END Q; + + PACKAGE NEW_Q IS NEW Q; + + FUNCTION INIT_3 (A : INTEGER) RETURN INTEGER IS + BEGIN + RETURN (A + IDENT_INT(3)); + END INIT_3; + + BEGIN + FAILED ("PROGRAM_ERROR NOT RAISED - 5"); + END; + + EXCEPTION + WHEN PROGRAM_ERROR => + NULL; + WHEN OTHERS => + FAILED ("UNEXPECTED EXCEPTION RAISED - 5"); + END; + + BEGIN + DECLARE + + FUNCTION FUN RETURN INTEGER; + + TYPE PARAM IS + RECORD + COMP : INTEGER := FUN; + END RECORD; + + GENERIC + TYPE T IS PRIVATE; + PACKAGE GP IS + OBJ : T; + END GP; + + PACKAGE INST IS NEW GP(PARAM); + + FUNCTION FUN RETURN INTEGER IS + BEGIN + RETURN (IDENT_INT(3)); + END FUN; + + BEGIN + FAILED ("PROGRAM_ERROR NOT RAISED - 6"); + END; + + EXCEPTION + WHEN PROGRAM_ERROR => + NULL; + WHEN OTHERS => + FAILED ("UNEXPECTED EXCEPTION RAISED - 6"); + END; + + RESULT; +END C39006A; diff --git a/gcc-4.9/gcc/testsuite/ada/acats/tests/c3/c39006b.ada b/gcc-4.9/gcc/testsuite/ada/acats/tests/c3/c39006b.ada new file mode 100644 index 000000000..f7b4f2757 --- /dev/null +++ b/gcc-4.9/gcc/testsuite/ada/acats/tests/c3/c39006b.ada @@ -0,0 +1,163 @@ +-- C39006B.ADA + +-- Grant of Unlimited Rights +-- +-- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687, +-- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained +-- unlimited rights in the software and documentation contained herein. +-- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making +-- this public release, the Government intends to confer upon all +-- recipients unlimited rights equal to those held by the Government. +-- These rights include rights to use, duplicate, release or disclose the +-- released technical data and computer software in whole or in part, in +-- any manner and for any purpose whatsoever, and to have or permit others +-- to do so. +-- +-- DISCLAIMER +-- +-- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR +-- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED +-- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF 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 PROGRAM_ERROR IS RAISED IF AN ATTEMPT IS MADE TO CALL A +-- SUBPROGRAM WHOSE BODY HAS NOT YET BEEN ELABORATED. CHECK THE +-- FOLLOWING: +-- B) THE SUBPROGRAM IS CALLED IN A PACKAGE BODY. +-- C) THE SUBPROGRAM IS AN ACTUAL GENERIC PARAMETER CALLED DURING +-- ELABORATION OF THE GENERIC INSTANTIATION. +-- D) THE SUBPROGRAM IS CALLED DURING ELABORATION OF AN OPTIONAL +-- PACKAGE BODY. + +-- TBN 8/19/86 + +WITH REPORT; USE REPORT; +PROCEDURE C39006B IS + +BEGIN + TEST ("C39006B", "CHECK THAT PROGRAM_ERROR IS RAISED IF AN " & + "ATTEMPT IS MADE TO CALL A SUBPROGRAM WHOSE " & + "BODY HAS NOT YET BEEN ELABORATED"); + BEGIN + DECLARE + PACKAGE PACK IS + FUNCTION FUN RETURN INTEGER; + PROCEDURE PROC (A : IN OUT INTEGER); + END PACK; + + PACKAGE BODY PACK IS + + VAR1 : INTEGER := 0; + + PROCEDURE PROC (A : IN OUT INTEGER) IS + BEGIN + IF A = IDENT_INT(1) THEN + A := A + FUN; + FAILED ("PROGRAM_ERROR NOT RAISED - 1"); + ELSE + A := IDENT_INT(1); + END IF; + EXCEPTION + WHEN PROGRAM_ERROR => + NULL; + WHEN OTHERS => + FAILED ("UNEXPECTED EXCEPTION RAISED " & + "1"); + END PROC; + + PACKAGE INSIDE IS + END INSIDE; + + PACKAGE BODY INSIDE IS + BEGIN + PROC (VAR1); + PROC (VAR1); + END INSIDE; + + FUNCTION FUN RETURN INTEGER IS + BEGIN + RETURN (IDENT_INT(1)); + END FUN; + + BEGIN + NULL; + END PACK; + + BEGIN + NULL; + END; + END; + + BEGIN + DECLARE + FUNCTION INIT_2 RETURN INTEGER; + + GENERIC + WITH FUNCTION FF RETURN INTEGER; + PACKAGE P IS + Y : INTEGER; + END P; + + GLOBAL_INT : INTEGER := IDENT_INT(1); + + PACKAGE BODY P IS + BEGIN + IF GLOBAL_INT = 1 THEN + Y := FF; + END IF; + END P; + + PACKAGE N IS + PACKAGE NEW_P IS NEW P(INIT_2); + END N; + + FUNCTION INIT_2 RETURN INTEGER IS + BEGIN + RETURN (IDENT_INT (1)); + END INIT_2; + + BEGIN + FAILED ("PROGRAM_ERROR NOT RAISED - 2"); + END; + + EXCEPTION + WHEN PROGRAM_ERROR => + NULL; + WHEN OTHERS => + FAILED ("UNEXPECTED EXCEPTION RAISED - 2"); + END; + + DECLARE + + PROCEDURE ADD1 (A : IN OUT INTEGER); + + PACKAGE P IS + VAR : INTEGER := IDENT_INT(1); + END P; + + PACKAGE BODY P IS + BEGIN + IF VAR = 1 THEN + ADD1 (VAR); + FAILED ("PROGRAM_ERROR NOT RAISED - 3"); + END IF; + EXCEPTION + WHEN PROGRAM_ERROR => + NULL; + WHEN OTHERS => + FAILED ("UNEXPECTED EXCEPTION RAISED - 3"); + END P; + + PROCEDURE ADD1 (A : IN OUT INTEGER) IS + BEGIN + A := A + IDENT_INT(1); + END ADD1; + + BEGIN + NULL; + END; + + RESULT; +END C39006B; diff --git a/gcc-4.9/gcc/testsuite/ada/acats/tests/c3/c39006c0.ada b/gcc-4.9/gcc/testsuite/ada/acats/tests/c3/c39006c0.ada new file mode 100644 index 000000000..c29dd6f31 --- /dev/null +++ b/gcc-4.9/gcc/testsuite/ada/acats/tests/c3/c39006c0.ada @@ -0,0 +1,69 @@ +-- C39006C0M.ADA + +-- Grant of Unlimited Rights +-- +-- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687, +-- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained +-- unlimited rights in the software and documentation contained herein. +-- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making +-- this public release, the Government intends to confer upon all +-- recipients unlimited rights equal to those held by the Government. +-- These rights include rights to use, duplicate, release or disclose the +-- released technical data and computer software in whole or in part, in +-- any manner and for any purpose whatsoever, and to have or permit others +-- to do so. +-- +-- DISCLAIMER +-- +-- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR +-- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED +-- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF 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 PROGRAM_ERROR IS RAISED IF AN ATTEMPT IS MADE TO CALL A +-- SUBPROGRAM WHOSE BODY HAS NOT YET BEEN ELABORATED. CHECK THE +-- FOLLOWING: +-- D) THE SUBPROGRAM IS CALLED DURING ELABORATION OF AN OPTIONAL +-- PACKAGE BODY SUBUNIT THAT IS IN C39006C1.ADA. + +-- SEPARATE FILES ARE: +-- C39006C0M THE MAIN PROCEDURE. +-- C39006C1 A SUBUNIT PACKAGE BODY. + +-- TBN 8/19/86 +-- LDC 5/26/88 CHANGED TEST NAME PARAMETER FROM C39006C0M TO +-- C39006C IN THE TEST CALL. + +WITH REPORT; USE REPORT; +PROCEDURE C39006C0M IS + + PACKAGE CALL_TEST_FIRST IS + END CALL_TEST_FIRST; + + PACKAGE BODY CALL_TEST_FIRST IS + BEGIN + TEST ("C39006C", "CHECK THAT PROGRAM_ERROR IS RAISED IF " & + "THE SUBPROGRAM WHOSE BODY HAS NOT BEEN " & + "ELABORATED IS CALLED DURING " & + "ELABORATION OF AN OPTIONAL PACKAGE " & + "BODY SUBUNIT"); + END CALL_TEST_FIRST; + + PROCEDURE ADD1 (A : IN OUT INTEGER); + + PACKAGE C39006C1 IS + VAR : INTEGER := IDENT_INT(1); + END C39006C1; + + PACKAGE BODY C39006C1 IS SEPARATE; + + PROCEDURE ADD1 (A : IN OUT INTEGER) IS + BEGIN + A := A + IDENT_INT(1); + END ADD1; + +BEGIN + RESULT; +END C39006C0M; diff --git a/gcc-4.9/gcc/testsuite/ada/acats/tests/c3/c39006c1.ada b/gcc-4.9/gcc/testsuite/ada/acats/tests/c3/c39006c1.ada new file mode 100644 index 000000000..0665cf037 --- /dev/null +++ b/gcc-4.9/gcc/testsuite/ada/acats/tests/c3/c39006c1.ada @@ -0,0 +1,41 @@ +-- C39006C1.ADA + +-- Grant of Unlimited Rights +-- +-- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687, +-- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained +-- unlimited rights in the software and documentation contained herein. +-- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making +-- this public release, the Government intends to confer upon all +-- recipients unlimited rights equal to those held by the Government. +-- These rights include rights to use, duplicate, release or disclose the +-- released technical data and computer software in whole or in part, in +-- any manner and for any purpose whatsoever, and to have or permit others +-- to do so. +-- +-- DISCLAIMER +-- +-- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR +-- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED +-- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE +-- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE +-- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A +-- PARTICULAR PURPOSE OF SAID MATERIAL. +--* +-- PACKAGE BODY SUBUNIT FOR C39006C0M.ADA. + +-- TBN 8/19/86 + +SEPARATE (C39006C0M) +PACKAGE BODY C39006C1 IS +BEGIN + IF VAR = IDENT_INT(1) THEN + ADD1 (VAR); + FAILED ("PROGRAM_ERROR NOT RAISED"); + END IF; +EXCEPTION + WHEN PROGRAM_ERROR => + NULL; + WHEN OTHERS => + FAILED ("UNEXPECTED EXCEPTION RAISED"); +END C39006C1; diff --git a/gcc-4.9/gcc/testsuite/ada/acats/tests/c3/c39006d.ada b/gcc-4.9/gcc/testsuite/ada/acats/tests/c3/c39006d.ada new file mode 100644 index 000000000..f2969e82e --- /dev/null +++ b/gcc-4.9/gcc/testsuite/ada/acats/tests/c3/c39006d.ada @@ -0,0 +1,144 @@ +-- C39006D.ADA + +-- Grant of Unlimited Rights +-- +-- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687, +-- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained +-- unlimited rights in the software and documentation contained herein. +-- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making +-- this public release, the Government intends to confer upon all +-- recipients unlimited rights equal to those held by the Government. +-- These rights include rights to use, duplicate, release or disclose the +-- released technical data and computer software in whole or in part, in +-- any manner and for any purpose whatsoever, and to have or permit others +-- to do so. +-- +-- DISCLAIMER +-- +-- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR +-- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED +-- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF 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 FUNCTION IS USED IN A DEFAULT EXPRESSION FOR A +-- SUBPROGRAM OR FORMAL GENERIC PARAMETER, PROGRAM_ERROR IS RAISED +-- WHEN AN ATTEMPT IS MADE TO EVALUATE THE DEFAULT EXPRESSION, +-- BECAUSE THE FUNCTION'S BODY HAS NOT BEEN ELABORATED YET. + +-- TBN 8/20/86 + +WITH REPORT; USE REPORT; +PROCEDURE C39006D IS + +BEGIN + TEST ("C39006D", "CHECK THAT IF A FUNCTION IS USED IN A DEFAULT " & + "EXPRESSION FOR A SUBPROGRAM OR FORMAL GENERIC " & + "PARAMETER, PROGRAM_ERROR IS RAISED WHEN AN " & + "ATTEMPT IS MADE TO EVALUATE THE DEFAULT " & + "EXPRESSION"); + DECLARE + FUNCTION FUN RETURN INTEGER; + + PACKAGE P IS + PROCEDURE DEFAULT (A : INTEGER := FUN); + END P; + + PACKAGE BODY P IS + PROCEDURE DEFAULT (A : INTEGER := FUN) IS + B : INTEGER := 1; + BEGIN + B := B + IDENT_INT(A); + END DEFAULT; + BEGIN + DEFAULT (2); + DEFAULT; + FAILED ("PROGRAM_ERROR NOT RAISED - 1"); + EXCEPTION + WHEN PROGRAM_ERROR => + NULL; + WHEN OTHERS => + FAILED ("UNEXPECTED EXCEPTION RAISED - 1"); + END P; + + FUNCTION FUN RETURN INTEGER IS + BEGIN + RETURN (IDENT_INT(1)); + END FUN; + BEGIN + NULL; + END; + + BEGIN + DECLARE + FUNCTION INIT_1 RETURN INTEGER; + + GENERIC + LENGTH : INTEGER := INIT_1; + PACKAGE P IS + TYPE ARRAY1 IS ARRAY (1 .. LENGTH) OF INTEGER; + END P; + + PACKAGE NEW_P1 IS NEW P (4); + PACKAGE NEW_P2 IS NEW P; + + FUNCTION INIT_1 RETURN INTEGER IS + BEGIN + RETURN (IDENT_INT(2)); + END INIT_1; + + BEGIN + FAILED ("PROGRAM_ERROR NOT RAISED - 2"); + END; + EXCEPTION + WHEN PROGRAM_ERROR => + NULL; + WHEN OTHERS => + FAILED ("UNEXPECTED EXCEPTION RAISED - 2"); + END; + + DECLARE + FUNCTION INIT_2 RETURN INTEGER; + + GLOBAL_INT : INTEGER := IDENT_INT(1); + + GENERIC + PACKAGE Q IS + PROCEDURE ADD1 (A : INTEGER := INIT_2); + END Q; + + PACKAGE BODY Q IS + PROCEDURE ADD1 (A : INTEGER := INIT_2) IS + B : INTEGER; + BEGIN + B := A; + END ADD1; + BEGIN + IF GLOBAL_INT = IDENT_INT(1) THEN + ADD1; + FAILED ("PROGRAM_ERROR NOT RAISED - 3"); + ELSE + ADD1 (2); + END IF; + + EXCEPTION + WHEN PROGRAM_ERROR => + NULL; + WHEN OTHERS => + FAILED ("UNEXPECTED EXCEPTION RAISED - 3"); + END Q; + + PACKAGE NEW_Q IS NEW Q; + + FUNCTION INIT_2 RETURN INTEGER IS + BEGIN + RETURN (IDENT_INT(1)); + END INIT_2; + + BEGIN + NULL; + END; + + RESULT; +END C39006D; diff --git a/gcc-4.9/gcc/testsuite/ada/acats/tests/c3/c39006e.ada b/gcc-4.9/gcc/testsuite/ada/acats/tests/c3/c39006e.ada new file mode 100644 index 000000000..77e527135 --- /dev/null +++ b/gcc-4.9/gcc/testsuite/ada/acats/tests/c3/c39006e.ada @@ -0,0 +1,213 @@ +-- C39006E.ADA + +-- Grant of Unlimited Rights +-- +-- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687, +-- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained +-- unlimited rights in the software and documentation contained herein. +-- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making +-- this public release, the Government intends to confer upon all +-- recipients unlimited rights equal to those held by the Government. +-- These rights include rights to use, duplicate, release or disclose the +-- released technical data and computer software in whole or in part, in +-- any manner and for any purpose whatsoever, and to have or permit others +-- to do so. +-- +-- DISCLAIMER +-- +-- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR +-- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED +-- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF 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 PROGRAM_ERROR IS NOT RAISED IF A SUBPROGRAM'S BODY HAS +-- BEEN ELABORATED BEFORE IT IS CALLED. CHECK THE FOLLOWING: +-- A) A SUBPROGRAM CAN APPEAR IN A NON-ELABORATED DECLARATIVE PART +-- OR PACKAGE SPECIFICATION BEFORE ITS BODY. + +-- TBN 8/21/86 + +WITH REPORT; USE REPORT; +PROCEDURE C39006E IS + +BEGIN + TEST ("C39006E", "CHECK THAT PROGRAM_ERROR IS NOT RAISED IF A " & + "SUBPROGRAM IS CALLED IN A NON-ELABORATED " & + "DECLARATIVE PART OR PACKAGE SPECIFICATION " & + "BEFORE ITS BODY IS ELABORATED"); + DECLARE -- (A) + + FUNCTION INIT_1 (A : INTEGER) RETURN INTEGER; + + PACKAGE P IS + PROCEDURE USE_INIT1; + END P; + + PACKAGE BODY P IS + PROCEDURE USE_INIT1 IS + BEGIN + IF NOT EQUAL (3, 3) THEN + DECLARE + X : INTEGER := INIT_1 (1); + BEGIN + NULL; + END; + ELSE + NULL; + END IF; + + EXCEPTION + WHEN PROGRAM_ERROR => + FAILED ("PROGRAM_ERROR RAISED - 1"); + WHEN OTHERS => + FAILED ("UNEXPECTED EXCEPTION RAISED - 1"); + END USE_INIT1; + + BEGIN + USE_INIT1; + END P; + + FUNCTION INIT_1 (A : INTEGER) RETURN INTEGER IS + BEGIN + RETURN (A + IDENT_INT(1)); + END INIT_1; + + BEGIN -- (A) + NULL; + END; -- (A) + + DECLARE -- (B) + + PROCEDURE INIT_2 (A : IN OUT INTEGER); + + PACKAGE P IS + FUNCTION USE_INIT2 RETURN BOOLEAN; + END P; + + PACKAGE BODY P IS + FUNCTION USE_INIT2 RETURN BOOLEAN IS + BEGIN + IF NOT EQUAL (3, 3) THEN + DECLARE + X : INTEGER; + BEGIN + INIT_2 (X); + END; + END IF; + RETURN IDENT_BOOL (FALSE); + + EXCEPTION + WHEN PROGRAM_ERROR => + FAILED ("PROGRAM_ERROR RAISED - 2"); + RETURN FALSE; + WHEN OTHERS => + FAILED ("UNEXPECTED EXCEPTION RAISED - 2"); + RETURN FALSE; + END USE_INIT2; + BEGIN + IF USE_INIT2 THEN + FAILED ("INCORRECT RESULTS FROM FUNCTION CALL - 2"); + END IF; + END P; + + PROCEDURE INIT_2 (A : IN OUT INTEGER) IS + BEGIN + A := A + IDENT_INT(1); + END INIT_2; + + BEGIN -- (B) + NULL; + END; -- (B) + + DECLARE -- (C) + FUNCTION INIT_3 RETURN INTEGER; + + PACKAGE Q IS + VAR : INTEGER; + END Q; + + PACKAGE BODY Q IS + BEGIN + IF NOT EQUAL (3, 3) THEN + VAR := INIT_3; + END IF; + EXCEPTION + WHEN PROGRAM_ERROR => + FAILED ("PROGRAM_ERROR RAISED - 3"); + WHEN OTHERS => + FAILED ("UNEXPECTED EXCEPTION RAISED - 3"); + END Q; + + FUNCTION INIT_3 RETURN INTEGER IS + BEGIN + RETURN IDENT_INT (1); + END INIT_3; + + BEGIN -- (C) + NULL; + END; -- (C) + + DECLARE -- (D) + PROCEDURE INIT_4 (A : IN OUT INTEGER); + + PACKAGE Q IS + VAR : INTEGER := 1; + END Q; + + PACKAGE BODY Q IS + BEGIN + IF NOT EQUAL (3, 3) THEN + INIT_4 (VAR); + END IF; + EXCEPTION + WHEN PROGRAM_ERROR => + FAILED ("PROGRAM_ERROR RAISED - 4"); + WHEN OTHERS => + FAILED ("UNEXPECTED EXCEPTION RAISED - 4"); + END Q; + + PROCEDURE INIT_4 (A : IN OUT INTEGER) IS + BEGIN + A := IDENT_INT (4); + END INIT_4; + + BEGIN -- (D) + NULL; + END; -- (D) + + BEGIN -- (E) + + DECLARE + FUNCTION INIT_5 (A : INTEGER) RETURN INTEGER; + + PROCEDURE USE_INIT5 IS + PACKAGE Q IS + X : INTEGER := INIT_5 (1); + END Q; + USE Q; + BEGIN + X := IDENT_INT (5); + + END USE_INIT5; + + FUNCTION INIT_5 (A : INTEGER) RETURN INTEGER IS + BEGIN + RETURN (A + IDENT_INT(1)); + END INIT_5; + + BEGIN + USE_INIT5; + END; + + EXCEPTION + WHEN PROGRAM_ERROR => + FAILED ("PROGRAM_ERROR RAISED - 5"); + WHEN OTHERS => + FAILED ("UNEXPECTED EXCEPTION RAISED - 5"); + + END; -- (E) + + RESULT; +END C39006E; diff --git a/gcc-4.9/gcc/testsuite/ada/acats/tests/c3/c39006f0.ada b/gcc-4.9/gcc/testsuite/ada/acats/tests/c3/c39006f0.ada new file mode 100644 index 000000000..58a9b894b --- /dev/null +++ b/gcc-4.9/gcc/testsuite/ada/acats/tests/c3/c39006f0.ada @@ -0,0 +1,44 @@ +-- C39006F0.ADA + +-- Grant of Unlimited Rights +-- +-- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687, +-- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained +-- unlimited rights in the software and documentation contained herein. +-- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making +-- this public release, the Government intends to confer upon all +-- recipients unlimited rights equal to those held by the Government. +-- These rights include rights to use, duplicate, release or disclose the +-- released technical data and computer software in whole or in part, in +-- any manner and for any purpose whatsoever, and to have or permit others +-- to do so. +-- +-- DISCLAIMER +-- +-- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR +-- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED +-- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF 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 NO PROGRAM_ERROR IS RAISED IF A SUBPROGRAM'S BODY HAS +-- BEEN ELABORATED BEFORE IT IS CALLED. CHECK THE FOLLOWING: +-- B) FOR A SUBPROGRAM LIBRARY UNIT USED IN ANOTHER UNIT, NO +-- PROGRAM_ERROR IS RAISED IF PRAGMA ELABORATE NAMES THE +-- SUBPROGRAM. + +-- THIS SUBPROGRAM LIBRARY UNIT IS USED BY C39006F2.ADA. + +-- HISTORY: +-- TBN 08/22/86 CREATED ORIGINAL TEST. +-- BCB 03/29/90 CORRECTED HEADER. CHANGED TEST NAME IN CALL +-- TO 'TEST'. + +WITH REPORT; USE REPORT; + +FUNCTION C39006F0 (A : INTEGER) RETURN INTEGER IS +BEGIN + RETURN (IDENT_INT(A)); +END C39006F0; diff --git a/gcc-4.9/gcc/testsuite/ada/acats/tests/c3/c39006f1.ada b/gcc-4.9/gcc/testsuite/ada/acats/tests/c3/c39006f1.ada new file mode 100644 index 000000000..b90477db8 --- /dev/null +++ b/gcc-4.9/gcc/testsuite/ada/acats/tests/c3/c39006f1.ada @@ -0,0 +1,42 @@ +-- C39006F1.ADA + +-- Grant of Unlimited Rights +-- +-- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687, +-- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained +-- unlimited rights in the software and documentation contained herein. +-- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making +-- this public release, the Government intends to confer upon all +-- recipients unlimited rights equal to those held by the Government. +-- These rights include rights to use, duplicate, release or disclose the +-- released technical data and computer software in whole or in part, in +-- any manner and for any purpose whatsoever, and to have or permit others +-- to do so. +-- +-- DISCLAIMER +-- +-- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR +-- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED +-- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF 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 NO PROGRAM_ERROR IS RAISED IF A SUBPROGRAM'S BODY HAS +-- BEEN ELABORATED BEFORE IT IS CALLED. CHECK THE FOLLOWING: +-- B) FOR A SUBPROGRAM LIBRARY UNIT USED IN ANOTHER UNIT, NO +-- PROGRAM_ERROR IS RAISED IF PRAGMA ELABORATE NAMES THE +-- SUBPROGRAM. + +-- THIS LIBRARY PACKAGE SPECIFICATION IS USED BY C39006F3M.ADA. + +-- HISTORY: +-- TBN 08/22/86 CREATED ORIGINAL TEST. +-- BCB 03/29/90 CORRECTED HEADER. CHANGED TEST NAME IN CALL +-- TO 'TEST'. +-- PWN 05/25/94 ADDED A PROCEDURE TO KEEP PACKAGE BODIES LEGAL. + +PACKAGE C39006F1 IS + PROCEDURE REQUIRE_BODY; +END C39006F1; diff --git a/gcc-4.9/gcc/testsuite/ada/acats/tests/c3/c39006f2.ada b/gcc-4.9/gcc/testsuite/ada/acats/tests/c3/c39006f2.ada new file mode 100644 index 000000000..2559b59aa --- /dev/null +++ b/gcc-4.9/gcc/testsuite/ada/acats/tests/c3/c39006f2.ada @@ -0,0 +1,130 @@ +-- C39006F2.ADA + +-- Grant of Unlimited Rights +-- +-- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687, +-- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained +-- unlimited rights in the software and documentation contained herein. +-- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making +-- this public release, the Government intends to confer upon all +-- recipients unlimited rights equal to those held by the Government. +-- These rights include rights to use, duplicate, release or disclose the +-- released technical data and computer software in whole or in part, in +-- any manner and for any purpose whatsoever, and to have or permit others +-- to do so. +-- +-- DISCLAIMER +-- +-- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR +-- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED +-- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF 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 NO PROGRAM_ERROR IS RAISED IF A SUBPROGRAM'S BODY HAS +-- BEEN ELABORATED BEFORE IT IS CALLED. CHECK THE FOLLOWING: +-- B) FOR A SUBPROGRAM LIBRARY UNIT USED IN ANOTHER UNIT, NO +-- PROGRAM_ERROR IS RAISED IF PRAGMA ELABORATE NAMES THE +-- SUBPROGRAM. + +-- THIS LIBRARY PACKAGE BODY IS USED BY C39006F3M.ADA. + +-- HISTORY: +-- TBN 08/22/86 CREATED ORIGINAL TEST. +-- BCB 03/29/90 CORRECTED HEADER. CHANGED TEST NAME IN CALL +-- TO 'TEST'. +-- PWN 05/25/94 ADDED A PROCEDURE TO KEEP PACKAGE BODIES LEGAL. + +WITH C39006F0; +WITH REPORT; USE REPORT; +PRAGMA ELABORATE (C39006F0, REPORT); + +PACKAGE BODY C39006F1 IS + + PROCEDURE REQUIRE_BODY IS + BEGIN + NULL; + END; + +BEGIN + TEST ("C39006F", "CHECK THAT NO PROGRAM_ERROR IS RAISED IF A " & + "SUBPROGRAM'S BODY HAS BEEN ELABORATED " & + "BEFORE IT IS CALLED, WHEN A SUBPROGRAM " & + "LIBRARY UNIT IS USED IN ANOTHER UNIT AND " & + "PRAGMA ELABORATE IS USED"); + BEGIN + DECLARE + VAR1 : INTEGER := C39006F0 (IDENT_INT(1)); + BEGIN + IF VAR1 /= IDENT_INT(1) THEN + FAILED ("INCORRECT RESULTS - 1"); + END IF; + END; + EXCEPTION + WHEN PROGRAM_ERROR => + FAILED ("PROGRAM_ERROR RAISED - 1"); + WHEN OTHERS => + FAILED ("UNEXPECTED EXCEPTION RAISED - 1"); + END; + + DECLARE + VAR2 : INTEGER := 1; + + PROCEDURE CHECK (B : IN OUT INTEGER) IS + BEGIN + B := C39006F0 (IDENT_INT(2)); + EXCEPTION + WHEN PROGRAM_ERROR => + FAILED ("PROGRAM_ERROR RAISED - 2"); + WHEN OTHERS => + FAILED ("UNEXPECTED EXCEPTION RAISED - 2"); + END CHECK; + BEGIN + CHECK (VAR2); + IF VAR2 /= IDENT_INT(2) THEN + FAILED ("INCORRECT RESULTS - 2"); + END IF; + END; + + DECLARE + PACKAGE P IS + VAR3 : INTEGER; + END P; + + PACKAGE BODY P IS + BEGIN + VAR3 := C39006F0 (IDENT_INT(3)); + IF VAR3 /= IDENT_INT(3) THEN + FAILED ("INCORRECT RESULTS - 3"); + END IF; + EXCEPTION + WHEN PROGRAM_ERROR => + FAILED ("PROGRAM_ERROR RAISED - 3"); + WHEN OTHERS => + FAILED ("UNEXPECTED EXCEPTION - 3"); + END P; + BEGIN + NULL; + END; + + DECLARE + GENERIC + VAR4 : INTEGER := 1; + PACKAGE Q IS + TYPE ARRAY_TYP1 IS ARRAY (1 .. VAR4) OF INTEGER; + ARRAY_1 : ARRAY_TYP1; + END Q; + + PACKAGE NEW_Q IS NEW Q (C39006F0 (IDENT_INT(4))); + + USE NEW_Q; + + BEGIN + IF ARRAY_1'LAST /= IDENT_INT(4) THEN + FAILED ("INCORRECT RESULTS - 4"); + END IF; + END; + +END C39006F1; diff --git a/gcc-4.9/gcc/testsuite/ada/acats/tests/c3/c39006f3.ada b/gcc-4.9/gcc/testsuite/ada/acats/tests/c3/c39006f3.ada new file mode 100644 index 000000000..206a47586 --- /dev/null +++ b/gcc-4.9/gcc/testsuite/ada/acats/tests/c3/c39006f3.ada @@ -0,0 +1,49 @@ +-- C39006F3M.ADA + +-- Grant of Unlimited Rights +-- +-- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687, +-- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained +-- unlimited rights in the software and documentation contained herein. +-- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making +-- this public release, the Government intends to confer upon all +-- recipients unlimited rights equal to those held by the Government. +-- These rights include rights to use, duplicate, release or disclose the +-- released technical data and computer software in whole or in part, in +-- any manner and for any purpose whatsoever, and to have or permit others +-- to do so. +-- +-- DISCLAIMER +-- +-- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR +-- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED +-- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF 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 NO PROGRAM_ERROR IS RAISED IF A SUBPROGRAM'S BODY HAS +-- BEEN ELABORATED BEFORE IT IS CALLED. CHECK THE FOLLOWING: +-- B) FOR A SUBPROGRAM LIBRARY UNIT USED IN ANOTHER UNIT, NO +-- PROGRAM_ERROR IS RAISED IF PRAGMA ELABORATE NAMES THE +-- SUBPROGRAM. + +-- SEPARATE FILES ARE: +-- C39006F0 A LIBRARY FUNCTION. +-- C39006F1 A LIBRARY PACKAGE SPECIFICATION. +-- C39006F2 A LIBRARY PACKAGE BODY. +-- C39006F3M (THIS FILE) THE MAIN PROCEDURE. + +-- HISTORY: +-- TBN 08/22/86 CREATED ORIGINAL TEST. +-- BCB 03/29/90 CORRECTED HEADER. CHANGED TEST NAME IN CALL +-- TO 'TEST'. + +WITH C39006F1; +WITH REPORT; USE REPORT; + +PROCEDURE C39006F3M IS +BEGIN + RESULT; +END C39006F3M; diff --git a/gcc-4.9/gcc/testsuite/ada/acats/tests/c3/c39006g.ada b/gcc-4.9/gcc/testsuite/ada/acats/tests/c3/c39006g.ada new file mode 100644 index 000000000..48990a442 --- /dev/null +++ b/gcc-4.9/gcc/testsuite/ada/acats/tests/c3/c39006g.ada @@ -0,0 +1,71 @@ +-- C39006G.ADA + +-- Grant of Unlimited Rights +-- +-- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687, +-- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained +-- unlimited rights in the software and documentation contained herein. +-- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making +-- this public release, the Government intends to confer upon all +-- recipients unlimited rights equal to those held by the Government. +-- These rights include rights to use, duplicate, release or disclose the +-- released technical data and computer software in whole or in part, in +-- any manner and for any purpose whatsoever, and to have or permit others +-- to do so. +-- +-- DISCLAIMER +-- +-- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR +-- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED +-- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF 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 PROGRAM_ERROR IS RAISED BY AN ATTEMPT TO CALL A +-- SUBPROGRAM WHOSE BODY IS NOT YET ELABORATED. USE A PACKAGE +-- WITH OPTIONAL BODY, WHERE THE SUBPROGRAM IS CALLED IN THE BODY. + +-- HISTORY: +-- BCB 08/01/88 CREATED ORIGINAL TEST. + +WITH REPORT; USE REPORT; + +PROCEDURE C39006G IS + + PROCEDURE INIT (X : IN OUT INTEGER); + + PACKAGE P IS + END P; + + PACKAGE BODY P IS + X : INTEGER := IDENT_INT(5); + BEGIN + TEST ("C39006G", "CHECK THAT PROGRAM_ERROR IS RAISED BY " & + "AN ATTEMPT TO CALL A SUBPROGRAM WHOSE " & + "BODY IS NOT YET ELABORATED. USE A " & + "PACKAGE WITH OPTIONAL BODY, WHERE THE " & + "SUBPROGRAM IS CALLED IN THE BODY"); + INIT(X); + FAILED ("NO EXCEPTION RAISED"); + IF X /= IDENT_INT(10) THEN + COMMENT ("TOTALLY IRRELEVANT"); + END IF; + RESULT; + EXCEPTION + WHEN PROGRAM_ERROR => + RESULT; + WHEN OTHERS => + FAILED ("OTHER EXCEPTION WAS RAISED"); + RESULT; + END P; + + PROCEDURE INIT (X : IN OUT INTEGER) IS + BEGIN + X := IDENT_INT(10); + END INIT; + +BEGIN + NULL; +END C39006G; diff --git a/gcc-4.9/gcc/testsuite/ada/acats/tests/c3/c39007a.ada b/gcc-4.9/gcc/testsuite/ada/acats/tests/c3/c39007a.ada new file mode 100644 index 000000000..e25d96ae6 --- /dev/null +++ b/gcc-4.9/gcc/testsuite/ada/acats/tests/c3/c39007a.ada @@ -0,0 +1,132 @@ +-- C39007A.ADA + +-- Grant of Unlimited Rights +-- +-- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687, +-- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained +-- unlimited rights in the software and documentation contained herein. +-- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making +-- this public release, the Government intends to confer upon all +-- recipients unlimited rights equal to those held by the Government. +-- These rights include rights to use, duplicate, release or disclose the +-- released technical data and computer software in whole or in part, in +-- any manner and for any purpose whatsoever, and to have or permit others +-- to do so. +-- +-- DISCLAIMER +-- +-- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR +-- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED +-- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF 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 PROGRAM_ERROR IS RAISED IF AN ATTEMPT IS MADE TO +-- INSTANTIATE A GENERIC UNIT WHOSE BODY HAS NOT BEEN ELABORATED. +-- CHECK THE FOLLOWING CASE: +-- A) A SIMPLE CASE WHERE THE GENERIC UNIT BODY OCCURS LATER IN +-- THE SAME DECLARATIVE PART. + +-- TBN 9/12/86 + +WITH REPORT; USE REPORT; +PROCEDURE C39007A IS + +BEGIN + TEST ("C39007A", "CHECK THAT PROGRAM_ERROR IS RAISED IF AN " & + "ATTEMPT IS MADE TO INSTANTIATE A GENERIC " & + "UNIT WHOSE BODY HAS NOT BEEN ELABORATED, " & + "BUT OCCURS IN THE SAME DECLARATIVE PART"); + + BEGIN + IF EQUAL (1, 1) THEN + DECLARE + GENERIC + PACKAGE P IS + A : INTEGER; + PROCEDURE ASSIGN (X : OUT INTEGER); + END P; + + PACKAGE NEW_P IS NEW P; + + PACKAGE BODY P IS + PROCEDURE ASSIGN (X : OUT INTEGER) IS + BEGIN + X := IDENT_INT (1); + END ASSIGN; + BEGIN + ASSIGN (A); + END P; + + BEGIN + NULL; + END; + FAILED ("PROGRAM_ERROR WAS NOT RAISED - 1"); + END IF; + + EXCEPTION + WHEN PROGRAM_ERROR => + NULL; + WHEN OTHERS => + FAILED ("UNEXPECTED EXCEPTION RAISED - 1"); + END; + +------------------------------------------------------------------------ + + BEGIN + IF EQUAL (2, 2) THEN + DECLARE + GENERIC + PROCEDURE ADD1 (X : IN OUT INTEGER); + + PROCEDURE NEW_ADD1 IS NEW ADD1; + + PROCEDURE ADD1 (X : IN OUT INTEGER) IS + BEGIN + X := X + IDENT_INT (1); + END ADD1; + BEGIN + NULL; + END; + FAILED ("PROGRAM_ERROR WAS NOT RAISED - 2"); + END IF; + + EXCEPTION + WHEN PROGRAM_ERROR => + NULL; + WHEN OTHERS => + FAILED ("UNEXPECTED EXCEPTION RAISED - 2"); + END; + +------------------------------------------------------------------------ + + BEGIN + IF EQUAL (3, 3) THEN + DECLARE + GENERIC + FUNCTION INIT RETURN INTEGER; + + FUNCTION NEW_INIT IS NEW INIT; + + FUNCTION INIT RETURN INTEGER IS + BEGIN + RETURN (IDENT_INT (1)); + END INIT; + BEGIN + NULL; + END; + FAILED ("PROGRAM_ERROR WAS NOT RAISED - 3"); + END IF; + + EXCEPTION + WHEN PROGRAM_ERROR => + NULL; + WHEN OTHERS => + FAILED ("UNEXPECTED EXCEPTION RAISED - 3"); + END; + +------------------------------------------------------------------------ + + RESULT; +END C39007A; diff --git a/gcc-4.9/gcc/testsuite/ada/acats/tests/c3/c39007b.ada b/gcc-4.9/gcc/testsuite/ada/acats/tests/c3/c39007b.ada new file mode 100644 index 000000000..c95c064d2 --- /dev/null +++ b/gcc-4.9/gcc/testsuite/ada/acats/tests/c3/c39007b.ada @@ -0,0 +1,83 @@ +-- C39007B.ADA + +-- Grant of Unlimited Rights +-- +-- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687, +-- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained +-- unlimited rights in the software and documentation contained herein. +-- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making +-- this public release, the Government intends to confer upon all +-- recipients unlimited rights equal to those held by the Government. +-- These rights include rights to use, duplicate, release or disclose the +-- released technical data and computer software in whole or in part, in +-- any manner and for any purpose whatsoever, and to have or permit others +-- to do so. +-- +-- DISCLAIMER +-- +-- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR +-- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED +-- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF 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 PROGRAM_ERROR IS RAISED BY AN ATTEMPT TO INSTANTIATE +-- A GENERIC UNIT WHOSE BODY IS NOT YET ELABORATED. USE A GENERIC +-- UNIT THAT IS DECLARED AND INSTANTIATED IN A PACKAGE +-- SPECIFICATION. + +-- HISTORY: +-- BCB 08/01/88 CREATED ORIGINAL TEST. + +WITH REPORT; USE REPORT; + +PROCEDURE C39007B IS + +BEGIN + TEST ("C39007B", "CHECK THAT PROGRAM_ERROR IS RAISED BY AN " & + "ATTEMPT TO INSTANTIATE A GENERIC UNIT WHOSE " & + "BODY IS NOT YET ELABORATED. USE A GENERIC " & + "UNIT THAT IS DECLARED AND INSTANTIATED IN A " & + "PACKAGE SPECIFICATION"); + + DECLARE + BEGIN + DECLARE + PACKAGE P IS + GENERIC + FUNCTION F RETURN BOOLEAN; + + FUNCTION NEW_F IS NEW F; + END P; + + PACKAGE BODY P IS + FUNCTION F RETURN BOOLEAN IS + BEGIN + RETURN TRUE; + END F; + END P; + BEGIN + FAILED ("NO EXCEPTION RAISED"); + DECLARE + X : BOOLEAN := IDENT_BOOL(FALSE); + BEGIN + X := P.NEW_F; + IF X /= IDENT_BOOL(TRUE) THEN + COMMENT ("NOT RELEVANT"); + END IF; + EXCEPTION + WHEN OTHERS => + FAILED ("EXCEPTION RAISED TOO LATE"); + END; + END; + EXCEPTION + WHEN PROGRAM_ERROR => + NULL; + WHEN OTHERS => + FAILED ("OTHER EXCEPTION RAISED"); + END; + + RESULT; +END C39007B; diff --git a/gcc-4.9/gcc/testsuite/ada/acats/tests/c3/c39008a.ada b/gcc-4.9/gcc/testsuite/ada/acats/tests/c3/c39008a.ada new file mode 100644 index 000000000..4e40dc391 --- /dev/null +++ b/gcc-4.9/gcc/testsuite/ada/acats/tests/c3/c39008a.ada @@ -0,0 +1,73 @@ +-- C39008A.ADA + +-- Grant of Unlimited Rights +-- +-- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687, +-- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained +-- unlimited rights in the software and documentation contained herein. +-- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making +-- this public release, the Government intends to confer upon all +-- recipients unlimited rights equal to those held by the Government. +-- These rights include rights to use, duplicate, release or disclose the +-- released technical data and computer software in whole or in part, in +-- any manner and for any purpose whatsoever, and to have or permit others +-- to do so. +-- +-- DISCLAIMER +-- +-- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR +-- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED +-- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF 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 PROGRAM_ERROR IS RAISED BY AN ATTEMPT TO ACTIVATE +-- A TASK BEFORE ITS BODY HAS BEEN ELABORATED. CHECK THE CASE IN +-- WHICH A TASK VARIABLE IS DECLARED IN A PACKAGE SPECIFICATION AND +-- THE PACKAGE BODY OCCURS BEFORE THE TASK BODY. + +-- HISTORY: +-- BCB 01/21/88 CREATED ORIGINAL TEST. + +WITH REPORT; USE REPORT; + +PROCEDURE C39008A IS + +BEGIN + TEST ("C39008A", "CHECK THAT PROGRAM_ERROR IS RAISED BY AN " & + "ATTEMPT TO ACTIVATE A TASK BEFORE ITS BODY " & + "HAS BEEN ELABORATED. CHECK THE CASE IN WHICH " & + "A TASK VARIABLE IS DECLARED IN A PACKAGE " & + "SPECIFICATION AND THE PACKAGE BODY OCCURS " & + "BEFORE THE TASK BODY"); + + BEGIN + DECLARE + TASK TYPE T; + + PACKAGE P IS + X : T; + END P; + + PACKAGE BODY P IS + END P; -- PROGRAM_ERROR. + + TASK BODY T IS + BEGIN + COMMENT ("TASK MESSAGE"); + END T; + BEGIN + FAILED ("PROGRAM_ERROR WAS NOT RAISED"); + END; + EXCEPTION + WHEN PROGRAM_ERROR => + COMMENT ("PROGRAM_ERROR WAS RAISED"); + WHEN OTHERS => + FAILED ("AN EXCEPTION OTHER THAN PROGRAM_ERROR WAS " & + "RAISED"); + END; + + RESULT; +END C39008A; diff --git a/gcc-4.9/gcc/testsuite/ada/acats/tests/c3/c39008b.ada b/gcc-4.9/gcc/testsuite/ada/acats/tests/c3/c39008b.ada new file mode 100644 index 000000000..d148e0ccf --- /dev/null +++ b/gcc-4.9/gcc/testsuite/ada/acats/tests/c3/c39008b.ada @@ -0,0 +1,77 @@ +-- C39008B.ADA + +-- Grant of Unlimited Rights +-- +-- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687, +-- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained +-- unlimited rights in the software and documentation contained herein. +-- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making +-- this public release, the Government intends to confer upon all +-- recipients unlimited rights equal to those held by the Government. +-- These rights include rights to use, duplicate, release or disclose the +-- released technical data and computer software in whole or in part, in +-- any manner and for any purpose whatsoever, and to have or permit others +-- to do so. +-- +-- DISCLAIMER +-- +-- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR +-- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED +-- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF 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 ACTIVATION OF A TASK IS ATTEMPTED BEFORE THE +-- ELABORATION OF THE CORRESPONDING BODY IS FINISHED, THE EXCEPTION +-- PROGRAM_ERROR IS RAISED, NOT TASKING_ERROR (SEE AI-00149). + +-- WEI 3/04/82 +-- JBG 2/17/84 +-- EG 11/02/84 +-- JBG 5/23/85 +-- JWC 6/28/85 RENAMED FROM C93007B-B.ADA + +WITH REPORT; + USE REPORT; + +PROCEDURE C39008B IS + +BEGIN + + TEST ("C39008B", "PROGRAM_ERROR AFTER ATTEMPT OF ACTIVATION " & + "BEFORE ELABORATION"); +BLOCK1: + BEGIN +BLOCK2: + DECLARE + TASK TYPE TT1; + + TYPE ATT1 IS ACCESS TT1; + + POINTER_TT1 : ATT1 := NEW TT1; -- ACCESSING TASK BODY + -- BEFORE ITS ELABORATION + + TASK BODY TT1 IS + BEGIN + FAILED ("TT1 ACTIVATED"); + END TT1; + + BEGIN + + FAILED ("TT1 ACTIVATED - 2"); + + END BLOCK2; + + EXCEPTION + WHEN TASKING_ERROR => + FAILED ("TASKING_ERROR RAISED"); + WHEN PROGRAM_ERROR => + NULL; + WHEN OTHERS => + FAILED ("OTHER EXCEPTION RAISED"); + END BLOCK1; + + RESULT; + +END C39008B; diff --git a/gcc-4.9/gcc/testsuite/ada/acats/tests/c3/c39008c.ada b/gcc-4.9/gcc/testsuite/ada/acats/tests/c3/c39008c.ada new file mode 100644 index 000000000..22d482559 --- /dev/null +++ b/gcc-4.9/gcc/testsuite/ada/acats/tests/c3/c39008c.ada @@ -0,0 +1,97 @@ +-- C39008C.ADA + +-- Grant of Unlimited Rights +-- +-- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687, +-- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained +-- unlimited rights in the software and documentation contained herein. +-- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making +-- this public release, the Government intends to confer upon all +-- recipients unlimited rights equal to those held by the Government. +-- These rights include rights to use, duplicate, release or disclose the +-- released technical data and computer software in whole or in part, in +-- any manner and for any purpose whatsoever, and to have or permit others +-- to do so. +-- +-- DISCLAIMER +-- +-- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR +-- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED +-- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF 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 PROGRAM_ERROR IS RAISED WHEN AN ATTEMPT IS MADE TO +-- ACTIVATE A TASK BEFORE ITS BODY HAS BEEN ELABORATED. CHECK THE +-- CASE IN WHICH SEVERAL TASKS ARE TO BE ACTIVATED, AND ONLY SOME +-- HAVE UNELABORATED BODIES; NO TASKS SHOULD BE ACTIVATED. + +-- HISTORY: +-- BCB 07/08/88 CREATED ORIGINAL TEST. + +WITH REPORT; USE REPORT; + +PROCEDURE C39008C IS + +BEGIN + TEST ("C39008C", "CHECK THAT PROGRAM_ERROR IS RAISED WHEN AN " & + "ATTEMPT IS MADE TO ACTIVATE A TASK BEFORE ITS " & + "BODY HAS BEEN ELABORATED. CHECK THE CASE IN " & + "WHICH SEVERAL TASKS ARE TO BE ACTIVATED, AND " & + "ONLY SOME HAVE UNELABORATED BODIES; NO TASKS " & + "SHOULD BE ACTIVATED"); + + BEGIN + DECLARE + TASK TYPE A; + + TASK TYPE B; + + TASK TYPE C; + + TASK TYPE D; + + PACKAGE P IS + W : A; + X : B; + Y : C; + Z : D; + END P; + + TASK BODY A IS + BEGIN + FAILED ("TASK A ACTIVATED"); + END A; + + TASK BODY D IS + BEGIN + FAILED ("TASK D ACTIVATED"); + END D; + + PACKAGE BODY P IS + END P; + + TASK BODY B IS + BEGIN + FAILED ("TASK B ACTIVATED"); + END B; + + TASK BODY C IS + BEGIN + FAILED ("TASK C ACTIVATED"); + END C; + BEGIN + FAILED ("PROGRAM_ERROR WAS NOT RAISED"); + END; + EXCEPTION + WHEN PROGRAM_ERROR => + NULL; + WHEN OTHERS => + FAILED ("AN EXCEPTION OTHER THAN PROGRAM_ERROR WAS " & + "RAISED"); + END; + + RESULT; +END C39008C; diff --git a/gcc-4.9/gcc/testsuite/ada/acats/tests/c3/c390a010.a b/gcc-4.9/gcc/testsuite/ada/acats/tests/c3/c390a010.a new file mode 100644 index 000000000..18016de09 --- /dev/null +++ b/gcc-4.9/gcc/testsuite/ada/acats/tests/c3/c390a010.a @@ -0,0 +1,127 @@ +-- C390A010.A +-- +-- Grant of Unlimited Rights +-- +-- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687, +-- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained +-- unlimited rights in the software and documentation contained herein. +-- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making +-- this public release, the Government intends to confer upon all +-- recipients unlimited rights equal to those held by the Government. +-- These rights include rights to use, duplicate, release or disclose the +-- released technical data and computer software in whole or in part, in +-- any manner and for any purpose whatsoever, and to have or permit others +-- to do so. +-- +-- DISCLAIMER +-- +-- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR +-- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED +-- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE +-- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE +-- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A +-- PARTICULAR PURPOSE OF SAID MATERIAL. +--* +-- +-- OBJECTIVE: +-- See C390A011.AM. +-- +-- TEST DESCRIPTION: +-- See C390A011.AM. +-- +-- TEST FILES: +-- This test consists of the following files: +-- +-- F390A00.A +-- => C390A010.A +-- C390A011.AM +-- +-- +-- CHANGE HISTORY: +-- 06 Dec 94 SAIC ACVC 2.0 +-- 04 Jun 96 SAIC ACVC 2.1: Modified prologue. +-- +--! + +with F390A00; -- Alert system abstraction. +package C390A010 is + + + type Low_Alert_Type is new F390A00.Alert_Type with record + Level : Integer := 0; -- Record extension of + end record; -- root tagged type. + + -- Inherits procedure Display from Alert_Type. + + procedure Handle (LA : in out Low_Alert_Type); -- Override parent's + -- primitive subprog. + + function Level_Of (LA : in Low_Alert_Type) -- To be inherited by + return Integer; -- all derivatives. + + + + -- Declarations required for component Action_Officer; + + type Person_Enum is (Nobody, Duty_Officer, + Watch_Commander, Commanding_Officer); + + + type Medium_Alert_Type is new Low_Alert_Type with record + Action_Officer : Person_Enum := Nobody; -- Record extension of + end record; -- record extension. + + -- Inherits (inherited) procedure Display from Low_Alert_Type. + -- Inherits function Level_Of from Low_Alert_Type. + + procedure Handle (MA : in out Medium_Alert_Type); -- Override parent's + -- primitive subprog. + + procedure Assign_Officer (MA : in out Medium_Alert_Type; + To : in Person_Enum); + + +end C390A010; + + + --==================================================================-- + + +package body C390A010 is + + use F390A00; -- Alert system abstraction. + + + function Level_Of (LA : in Low_Alert_Type) return Integer is + begin + return (LA.Level + 1); + end Level_Of; + + + procedure Handle (LA : in out Low_Alert_Type) is + begin + Handle (Alert_Type (LA)); -- Call parent's op (type conversion). + LA.Level := Level_Of (LA); -- Call newly declared operation. + LA.Display_On := Teletype; + Display (LA); -- Call inherited operation. + end Handle; + + + procedure Assign_Officer (MA : in out Medium_Alert_Type; + To : in Person_Enum) is + begin + MA.Action_Officer := To; + end Assign_Officer; + + + procedure Handle (MA : in out Medium_Alert_Type) is + begin + Handle (Low_Alert_Type (MA)); -- Call parent's op (type conversion). + MA.Level := Level_Of (MA); -- Call inherited operation. + Assign_Officer (MA, Duty_Officer); -- Call newly declared operation. + MA.Display_On := Console; + Display (MA); -- Call twice-inherited operation. + end Handle; + + +end C390A010; diff --git a/gcc-4.9/gcc/testsuite/ada/acats/tests/c3/c390a011.am b/gcc-4.9/gcc/testsuite/ada/acats/tests/c3/c390a011.am new file mode 100644 index 000000000..b5234e913 --- /dev/null +++ b/gcc-4.9/gcc/testsuite/ada/acats/tests/c3/c390a011.am @@ -0,0 +1,218 @@ +-- C390A011.AM +-- +-- Grant of Unlimited Rights +-- +-- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687, +-- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained +-- unlimited rights in the software and documentation contained herein. +-- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making +-- this public release, the Government intends to confer upon all +-- recipients unlimited rights equal to those held by the Government. +-- These rights include rights to use, duplicate, release or disclose the +-- released technical data and computer software in whole or in part, in +-- any manner and for any purpose whatsoever, and to have or permit others +-- to do so. +-- +-- DISCLAIMER +-- +-- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR +-- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED +-- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE +-- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE +-- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A +-- PARTICULAR PURPOSE OF SAID MATERIAL. +--* +-- +-- OBJECTIVE: +-- Check that a nonprivate tagged type declared in a package specification +-- may be extended with a record extension in a different package +-- specification, and that this record extension may in turn be extended +-- by a record extension. +-- +-- Check that each derivative inherits the user-defined primitive +-- subprograms of its parent (including those that its parent inherited), +-- that it may override these inherited primitive subprograms, and that it +-- may also declare its own primitive subprograms. +-- +-- Check that predefined equality operators are defined for the tagged +-- type and its derivatives. +-- +-- Check that type conversion is defined from a type extension to its +-- parent, and that this parent itself may be a type extension. +-- +-- TEST DESCRIPTION: +-- Declare a root tagged type and two associated primitive subprograms +-- in a package specification (foundation code). +-- +-- Extend the root type with a record extension in a different package +-- specification. Declare a new primitive subprogram for the extension, +-- and override one of the two inherited subprograms. Within the +-- overriding subprogram, utilize type conversion to call the parent's +-- implementation of the same subprogram. Also within the overriding +-- subprogram, call the new primitive subprogram and each inherited +-- subprogram. +-- +-- Extend the extension with a record extension in the same package +-- specification. Declare a new primitive subprogram for this second +-- extension, and override one of the three inherited subprograms. +-- Within the overriding subprogram, utilize type conversion to call the +-- parent's implementation of the same subprogram. Also within the +-- overriding subprogram, call the new primitive subprogram and each +-- inherited subprogram. +-- +-- In the main program, declare objects of the root tagged type +-- and the two type extensions. For each object, call the overriding +-- subprogram, and verify the correctness of the components by using +-- aggregates and equality operators, or by checking the components +-- directly. +-- +-- TEST FILES: +-- This test consists of the following files: +-- +-- F390A00.A +-- C390A010.A +-- => C390A011.AM +-- +-- +-- CHANGE HISTORY: +-- 06 Dec 94 SAIC ACVC 2.0 +-- 04 Jun 96 SAIC ACVC 2.1: Modified prologue. +-- +--! + +with Report; + +with F390A00; -- Basic alert abstraction. +with C390A010; -- Extended alert abstraction. + +use F390A00; -- Primitive operations of Alert_Type directly visible. + +with Ada.Calendar; + +procedure C390A011 is + use type Ada.Calendar.Time; -- Equality/inequality ops directly visible. +begin + + Report.Test ("C390A01", "Primitive operation inheritance by type " & + "extensions: all extensions declared in same package, " & + "but a different package from that of root type"); + + + ALERT_SUBTEST: ------------------------------------------------------------- + + declare + Alarm : F390A00.Alert_Type; -- Root tagged type. + begin + + -- Check "/=" operator availability. Aggregate with positional + -- associations: + if Alarm /= (Default_Time, Null_Device) then + Report.Failed ("Wrong initial values for Alert_Type"); + end if; + + Handle (Alarm); + + -- Check "=" operator availability. Aggregate with named + -- associations: + if not (Alarm = (Arrival_Time => Alert_Time, + Display_On => Null_Device)) + then + Report.Failed ("Wrong values for Alert_Type after Handle"); + end if; + + end Alert_Subtest; + + + -- Check intermediate display counts: + + if F390A00.Display_Count_For (Null_Device) /= 1 or + F390A00.Display_Count_For (Teletype) /= 0 or + F390A00.Display_Count_For (Console) /= 0 or + F390A00.Display_Count_For (Big_Screen) /= 0 + then + Report.Failed ("Wrong display counts after Alert_Type"); + end if; + + + LOW_ALERT_SUBTEST: --------------------------------------------------------- + + declare + Low_Alarm : C390A010.Low_Alert_Type; -- Extension of tagged type. + use C390A010; -- Primitive operations of extension directly visible. + begin + + -- Check "=" operator availability. Aggregate with positional + -- associations: + if not (Low_Alarm = (Default_Time, Null_Device, 0)) then + Report.Failed ("Wrong initial values for Low_Alert_Type"); + end if; + + Handle (Low_Alarm); + + -- Check component availability: + if Low_Alarm.Arrival_Time /= Alert_Time or + Low_Alarm.Display_On /= Teletype or + Low_Alarm.Level /= 1 + then + Report.Failed ("Wrong values for Low_Alert_Type after Handle"); + end if; + + end Low_Alert_Subtest; + + + -- Check intermediate display counts: + + if F390A00.Display_Count_For /= (Null_Device => 2, + Teletype => 1, + Console => 0, + Big_Screen => 0) + then + Report.Failed ("Wrong display counts after Low_Alert_Type"); + end if; + + + MEDIUM_ALERT_SUBTEST: ------------------------------------------------------ + + declare + Medium_Alarm : C390A010.Medium_Alert_Type; -- Extension of extension. + use C390A010; -- Primitive operations of extension directly visible. + begin + + -- Check component availability: + if Medium_Alarm.Level /= 0 or + Medium_Alarm.Arrival_Time /= Default_Time or + Medium_Alarm.Action_Officer /= Nobody or + Medium_Alarm.Display_On /= Null_Device + then + Report.Failed ("Wrong initial values for Medium_Alert_Type"); + end if; + + Handle (Medium_Alarm); + + -- Check "/=" operator availability. Aggregate with named + -- associations: + if Medium_Alarm /= (Arrival_Time => Alert_Time, + Display_On => Console, + Level => 2, + Action_Officer => Duty_Officer) + then + Report.Failed ("Wrong values for Medium_Alert_Type after Handle"); + end if; + + end Medium_Alert_Subtest; + + + -- Check final display counts: + + if F390A00.Display_Count_For /= (Null_Device => 3, + Teletype => 2, + Console => 1, + Big_Screen => 0) + then + Report.Failed ("Wrong display counts after Medium_Alert_Type"); + end if; + + + Report.Result; + +end C390A011; diff --git a/gcc-4.9/gcc/testsuite/ada/acats/tests/c3/c390a020.a b/gcc-4.9/gcc/testsuite/ada/acats/tests/c3/c390a020.a new file mode 100644 index 000000000..29cd3ca97 --- /dev/null +++ b/gcc-4.9/gcc/testsuite/ada/acats/tests/c3/c390a020.a @@ -0,0 +1,90 @@ +-- C390A020.A +-- +-- Grant of Unlimited Rights +-- +-- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687, +-- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained +-- unlimited rights in the software and documentation contained herein. +-- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making +-- this public release, the Government intends to confer upon all +-- recipients unlimited rights equal to those held by the Government. +-- These rights include rights to use, duplicate, release or disclose the +-- released technical data and computer software in whole or in part, in +-- any manner and for any purpose whatsoever, and to have or permit others +-- to do so. +-- +-- DISCLAIMER +-- +-- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR +-- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED +-- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE +-- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE +-- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A +-- PARTICULAR PURPOSE OF SAID MATERIAL. +--* +-- +-- OBJECTIVE: +-- See C390A022.AM. +-- +-- TEST DESCRIPTION: +-- See C390A022.AM. +-- +-- TEST FILES: +-- This test consists of the following files: +-- +-- F390A00.A +-- => C390A020.A +-- C390A021.A +-- C390A022.AM +-- +-- +-- CHANGE HISTORY: +-- 06 Dec 94 SAIC ACVC 2.0 +-- 04 Jun 96 SAIC ACVC 2.1: Modified prologue. +-- +--! + +with F390A00; -- Alert system abstraction. +package C390A020 is + + + type Low_Alert_Type is new F390A00.Alert_Type with record + Level : Integer := 0; -- Record extension of + end record; -- root tagged type. + + -- Inherits procedure Display from Alert_Type. + + procedure Handle (LA : in out Low_Alert_Type); -- Override parent's + -- primitive subprog. + + function Level_Of (LA : in Low_Alert_Type) -- To be inherited by + return Integer; -- all derivatives. + + +end C390A020; + + + --==================================================================-- + + +package body C390A020 is + + use F390A00; -- Alert system abstraction. + + + function Level_Of (LA : in Low_Alert_Type) return Integer is + begin + return (LA.Level + 1); + end Level_Of; + + + procedure Handle (LA : in out Low_Alert_Type) is + begin + Handle (Alert_Type (LA)); -- Call parent's oper. (type conversion). + LA.Level := Level_Of (LA); -- Call newly declared operation. + LA.Display_On := Teletype; + Display (LA); -- Call inherited operation. + end Handle; + + +end C390A020; diff --git a/gcc-4.9/gcc/testsuite/ada/acats/tests/c3/c390a021.a b/gcc-4.9/gcc/testsuite/ada/acats/tests/c3/c390a021.a new file mode 100644 index 000000000..5d099f370 --- /dev/null +++ b/gcc-4.9/gcc/testsuite/ada/acats/tests/c3/c390a021.a @@ -0,0 +1,133 @@ +-- C390A021.A +-- +-- Grant of Unlimited Rights +-- +-- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687, +-- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained +-- unlimited rights in the software and documentation contained herein. +-- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making +-- this public release, the Government intends to confer upon all +-- recipients unlimited rights equal to those held by the Government. +-- These rights include rights to use, duplicate, release or disclose the +-- released technical data and computer software in whole or in part, in +-- any manner and for any purpose whatsoever, and to have or permit others +-- to do so. +-- +-- DISCLAIMER +-- +-- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR +-- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED +-- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE +-- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE +-- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A +-- PARTICULAR PURPOSE OF SAID MATERIAL. +--* +-- +-- OBJECTIVE: +-- See C390A022.AM. +-- +-- TEST DESCRIPTION: +-- See C390A022.AM. +-- +-- TEST FILES: +-- This test consists of the following files: +-- +-- F390A00.A +-- C390A020.A +-- => C390A021.A +-- C390A022.AM +-- +-- +-- CHANGE HISTORY: +-- 06 Dec 94 SAIC ACVC 2.0 +-- 04 Jun 96 SAIC ACVC 2.1: Modified prologue. +-- +--! + +with C390A020; -- Extended alert abstraction. +package C390A021 is + + + -- Declarations used by component Action_Officer; + + type Person_Enum is (Nobody, Duty_Officer, + Watch_Commander, Commanding_Officer); + + + type Medium_Alert_Type is new C390A020.Low_Alert_Type + with private; -- Private extension of + -- record extension. + + -- Inherits (inherited) procedure Display from Low_Alert_Type. + -- Inherits function Level_Of from Low_Alert_Type. + + procedure Handle (MA : in out Medium_Alert_Type); -- Override parent's + -- primitive subprog. + + procedure Assign_Officer (MA : in out Medium_Alert_Type; + To : in Person_Enum); + + + -- The following two functions are needed to verify the values of the + -- extension's private components. + + function Initial_Values_Okay (MA : in Medium_Alert_Type) + return Boolean; + + function Bad_Final_Values (MA : in Medium_Alert_Type) + return Boolean; + + +private + + type Medium_Alert_Type is new C390A020.Low_Alert_Type with record + Action_Officer : Person_Enum := Nobody; + end record; + +end C390A021; + + + --==================================================================-- + + +with F390A00; -- Basic alert abstraction. +use F390A00; +package body C390A021 is + + use C390A020; -- Extended alert abstraction. + + + procedure Assign_Officer (MA : in out Medium_Alert_Type; + To : in Person_Enum) is + begin + MA.Action_Officer := To; + end Assign_Officer; + + + procedure Handle (MA : in out Medium_Alert_Type) is + begin + Handle (Low_Alert_Type (MA)); -- Call parent's op (type conversion). + MA.Level := Level_Of (MA); -- Call inherited operation. + Assign_Officer (MA, Duty_Officer); -- Call newly declared operation. + MA.Display_On := Console; + Display (MA); -- Call twice-inherited operation. + end Handle; + + + function Initial_Values_Okay (MA : in Medium_Alert_Type) return Boolean is + begin + return (MA = (Arrival_Time => Default_Time, -- Check "=" operator + Display_On => Null_Device, -- availability. + Level => 0, -- Aggregate with + Action_Officer => Nobody)); -- named associations. + end Initial_Values_Okay; + + + function Bad_Final_Values (MA : in Medium_Alert_Type) return Boolean is + begin + return (MA /= (Alert_Time, Console, -- Check "/=" operator + 2 , Duty_Officer)); -- availability. + end Bad_Final_Values; -- Aggregate with + -- positional assoc. + +end C390A021; diff --git a/gcc-4.9/gcc/testsuite/ada/acats/tests/c3/c390a022.am b/gcc-4.9/gcc/testsuite/ada/acats/tests/c3/c390a022.am new file mode 100644 index 000000000..3ba273fe5 --- /dev/null +++ b/gcc-4.9/gcc/testsuite/ada/acats/tests/c3/c390a022.am @@ -0,0 +1,179 @@ +-- C390A022.AM +-- +-- Grant of Unlimited Rights +-- +-- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687, +-- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained +-- unlimited rights in the software and documentation contained herein. +-- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making +-- this public release, the Government intends to confer upon all +-- recipients unlimited rights equal to those held by the Government. +-- These rights include rights to use, duplicate, release or disclose the +-- released technical data and computer software in whole or in part, in +-- any manner and for any purpose whatsoever, and to have or permit others +-- to do so. +-- +-- DISCLAIMER +-- +-- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR +-- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED +-- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE +-- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE +-- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A +-- PARTICULAR PURPOSE OF SAID MATERIAL. +--* +-- +-- OBJECTIVE: +-- Check that a nonprivate tagged type declared in a package specification +-- may be extended with a record extension in a different package +-- specification, and that this record extension may in turn be extended +-- by a private extension in a third package. +-- +-- Check that each derivative inherits the user-defined primitive +-- subprograms of its parent (including those that its parent inherited), +-- that it may override these inherited primitive subprograms, and that it +-- may also declare its own primitive subprograms. +-- +-- Check that predefined equality operators are defined for the tagged +-- type and its derivatives. +-- +-- Check that type conversion is defined from a type extension to its +-- parent, and that this parent itself may be a type extension. +-- +-- TEST DESCRIPTION: +-- Declare a root tagged type and two associated primitive subprograms +-- in a package specification (foundation code). +-- +-- Extend the root type with a record extension in a different package +-- specification. Declare a new primitive subprogram for the extension, +-- and override one of the two inherited subprograms. Within the +-- overriding subprogram, utilize type conversion to call the parent's +-- implementation of the same subprogram. Also within the overriding +-- subprogram, call the new primitive subprogram and each inherited +-- subprogram. +-- +-- Extend the extension with a private extension in a third package +-- specification. Declare a new primitive subprogram for this private +-- extension, and override one of the three inherited subprograms. +-- Within the overriding subprogram, utilize type conversion to call the +-- parent's implementation of the same subprogram. Also within the +-- overriding subprogram, call the new primitive subprogram and each +-- inherited subprogram. +-- +-- Also in the third package, declare two operations of the private +-- extension which utilize aggregates and equality operators to verify +-- the correctness of the components. +-- +-- In the main program, declare objects of the two extended types. +-- For each object, call the overriding subprogram, and verify the +-- correctness of the components by using aggregates and equality +-- operators, or by checking the components directly, or, for the private +-- extension, by calling the verification operations declared in the +-- third package. +-- +-- TEST FILES: +-- This test consists of the following files: +-- +-- F390A00.A +-- C390A020.A +-- C390A021.A +-- => C390A022.AM +-- +-- +-- CHANGE HISTORY: +-- 06 Dec 94 SAIC ACVC 2.0 +-- 04 Jun 96 SAIC ACVC 2.1: Modified prologue. +-- +--! + +with Report; + +with F390A00; -- Basic alert abstraction. +with C390A020; -- Extended alert abstraction. +with C390A021; -- Further extended alert abstraction. + +use F390A00; -- Primitive operations of Alert_Type directly visible. + +with Ada.Calendar; + +procedure C390A022 is + use type Ada.Calendar.Time; -- Equality/inequality ops directly visible. +begin + + Report.Test ("C390A02", "Primitive operation inheritance by type " & + "extensions: all extensions declared in different " & + "packages; second extension is private"); + + + -- The case for type F390A00.Alert_Type is tested in C390A01. + -- That subtest is not repeated here. + + + LOW_ALERT_SUBTEST: --------------------------------------------------------- + + declare + Low_Alarm : C390A020.Low_Alert_Type; -- Extension of tagged type. + use C390A020; -- Primitive operations of extension directly visible. + begin + + -- Check "=" operator availability. Aggregate with positional + -- associations: + if not (Low_Alarm = (Default_Time, Null_Device, 0)) then + Report.Failed ("Wrong initial values for Low_Alert_Type"); + end if; + + Handle (Low_Alarm); + + -- Check component availability: + if Low_Alarm.Arrival_Time /= Alert_Time or + Low_Alarm.Display_On /= Teletype or + Low_Alarm.Level /= 1 + then + Report.Failed ("Wrong values for Low_Alert_Type after Handle"); + end if; + end Low_Alert_Subtest; + + + -- Check intermediate display counts: + + if F390A00.Display_Count_For /= (Null_Device => 1, + Teletype => 1, + Console => 0, + Big_Screen => 0) + then + Report.Failed ("Wrong display counts after Low_Alert_Type"); + end if; + + + MEDIUM_ALERT_SUBTEST: ------------------------------------------------------ + + declare + Medium_Alarm : C390A021.Medium_Alert_Type; -- Priv. ext. of extension. + use C390A021; -- Primitive operations of extension directly visible. + begin + if not C390A021.Initial_Values_Okay (Medium_Alarm) then + Report.Failed ("Wrong initial values for Medium_Alert_Type"); + end if; + + Handle (Medium_Alarm); + + if C390A021.Bad_Final_Values (Medium_Alarm) then + Report.Failed ("Wrong values for Medium_Alert_Type after Handle"); + end if; + end Medium_Alert_Subtest; + + + -- Check final display counts: + + if F390A00.Display_Count_For /= (Null_Device => 2, + Teletype => 2, + Console => 1, + Big_Screen => 0) + then + Report.Failed ("Wrong display counts after Medium_Alert_Type"); + end if; + + + Report.Result; + +end C390A022; diff --git a/gcc-4.9/gcc/testsuite/ada/acats/tests/c3/c390a030.a b/gcc-4.9/gcc/testsuite/ada/acats/tests/c3/c390a030.a new file mode 100644 index 000000000..51554a49a --- /dev/null +++ b/gcc-4.9/gcc/testsuite/ada/acats/tests/c3/c390a030.a @@ -0,0 +1,188 @@ +-- C390A030.A +-- +-- Grant of Unlimited Rights +-- +-- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687, +-- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained +-- unlimited rights in the software and documentation contained herein. +-- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making +-- this public release, the Government intends to confer upon all +-- recipients unlimited rights equal to those held by the Government. +-- These rights include rights to use, duplicate, release or disclose the +-- released technical data and computer software in whole or in part, in +-- any manner and for any purpose whatsoever, and to have or permit others +-- to do so. +-- +-- DISCLAIMER +-- +-- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR +-- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED +-- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE +-- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE +-- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A +-- PARTICULAR PURPOSE OF SAID MATERIAL. +--* +-- +-- OBJECTIVE: +-- See C390A031.AM. +-- +-- TEST DESCRIPTION: +-- See C390A031.AM. +-- +-- TEST FILES: +-- This test consists of the following files: +-- +-- F390A00.A +-- => C390A030.A +-- C390A031.AM +-- +-- +-- CHANGE HISTORY: +-- 06 Dec 94 SAIC ACVC 2.0 +-- 04 Jun 96 SAIC ACVC 2.1: Modified prologue. +-- +--! + +with F390A00; -- Alert system abstraction. +package C390A030 is + + + type Low_Alert_Type is new F390A00.Alert_Type -- Private extension of + with private; -- root tagged type. + + -- Inherits procedure Display from Alert_Type. + + procedure Handle (LA : in out Low_Alert_Type); -- Override parent's + -- primitive subprog. + + function Level_Of (LA : in Low_Alert_Type) -- To be inherited by + return Integer; -- all derivatives. + + + -- The following two functions are needed to verify the values of the + -- extension's private components. + + function Initial_Values_Okay (LA : in Low_Alert_Type) + return Boolean; + + function Bad_Final_Values (LA : in Low_Alert_Type) + return Boolean; + + + -- Declarations used by private extension component. + + type Person_Enum is (Nobody, Duty_Officer, + Watch_Commander, Commanding_Officer); + + + type Medium_Alert_Type is new Low_Alert_Type -- Private extension of + with private; -- private extension. + + -- Inherits (inherited) procedure Display from Low_Alert_Type. + -- Inherits function Level_Of from Low_Alert_Type. + + procedure Handle (MA : in out Medium_Alert_Type); -- Override parent's + -- primitive subprog. + + procedure Assign_Officer (MA : in out Medium_Alert_Type; + To : in Person_Enum); + + + -- The following two functions are needed to verify the values of the + -- extension's private components. + + function Initial_Values_Okay (MA : in Medium_Alert_Type) + return Boolean; -- Override parent's + -- operation. + + function Bad_Final_Values (MA : in Medium_Alert_Type) + return Boolean; -- Override parent's + -- operation. + +private + + type Low_Alert_Type is new F390A00.Alert_Type with record + Level : Integer := 0; + end record; + + + type Medium_Alert_Type is new Low_Alert_Type with record + Action_Officer : Person_Enum := Nobody; + end record; + +end C390A030; + + + --==================================================================-- + + +package body C390A030 is + + use F390A00; -- Alert system abstraction. + + + function Level_Of (LA : in Low_Alert_Type) return Integer is + begin + return (LA.Level + 1); + end Level_Of; + + + procedure Handle (LA : in out Low_Alert_Type) is + begin + Handle (Alert_Type (LA)); -- Call parent's operation (type conversion). + LA.Level := Level_Of (LA); -- Call newly declared operation. + LA.Display_On := Teletype; + Display (LA); -- Call inherited operation. + end Handle; + + + function Initial_Values_Okay (LA : in Low_Alert_Type) return Boolean is + begin + return (LA = (Arrival_Time => Default_Time, -- Check "=" operator + Display_On => Null_Device, -- availability. + Level => 0)); -- Aggregate with + end Initial_Values_Okay; -- named associations. + + + function Bad_Final_Values (LA : in Low_Alert_Type) return Boolean is + begin + return (LA /= (Alert_Time, Teletype, 1)); -- Check "/=" operator + -- availability. + end Bad_Final_Values; -- Aggregate with + -- positional assoc. + + procedure Assign_Officer (MA : in out Medium_Alert_Type; + To : in Person_Enum) is + begin + MA.Action_Officer := To; + end Assign_Officer; + + + procedure Handle (MA : in out Medium_Alert_Type) is + begin + Handle (Low_Alert_Type (MA)); -- Call parent's op (type conversion). + MA.Level := Level_Of (MA); -- Call inherited operation. + Assign_Officer (MA, Duty_Officer); -- Call newly declared operation. + MA.Display_On := Console; + Display (MA); -- Call twice-inherited operation. + end Handle; + + + function Initial_Values_Okay (MA : in Medium_Alert_Type) return Boolean is + begin + -- Call parent's operation (type conversion). + return (Initial_Values_Okay (Low_Alert_Type (MA)) and + MA.Action_Officer = Nobody); + end Initial_Values_Okay; + + + function Bad_Final_Values (MA : in Medium_Alert_Type) return Boolean is + begin + return not (MA = (Arrival_Time => Alert_Time, -- Check "=" operator + Display_On => Console, -- availability. + Level => 2, -- Aggregate with + Action_Officer => Duty_Officer));-- named associations. + end Bad_Final_Values; + + +end C390A030; diff --git a/gcc-4.9/gcc/testsuite/ada/acats/tests/c3/c390a031.am b/gcc-4.9/gcc/testsuite/ada/acats/tests/c3/c390a031.am new file mode 100644 index 000000000..7f380c61d --- /dev/null +++ b/gcc-4.9/gcc/testsuite/ada/acats/tests/c3/c390a031.am @@ -0,0 +1,167 @@ +-- C390A031.AM +-- +-- Grant of Unlimited Rights +-- +-- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687, +-- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained +-- unlimited rights in the software and documentation contained herein. +-- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making +-- this public release, the Government intends to confer upon all +-- recipients unlimited rights equal to those held by the Government. +-- These rights include rights to use, duplicate, release or disclose the +-- released technical data and computer software in whole or in part, in +-- any manner and for any purpose whatsoever, and to have or permit others +-- to do so. +-- +-- DISCLAIMER +-- +-- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR +-- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED +-- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE +-- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE +-- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A +-- PARTICULAR PURPOSE OF SAID MATERIAL. +--* +-- +-- OBJECTIVE: +-- Check that a nonprivate tagged type declared in a package specification +-- may be extended with a private extension in a different package +-- specification, and that this private extension may in turn be extended +-- by a private extension. +-- +-- Check that each derivative inherits the user-defined primitive +-- subprograms of its parent (including those that its parent inherited), +-- that it may override these inherited primitive subprograms, and that it +-- may also declare its own primitive subprograms. +-- +-- Check that predefined equality operators are defined for the tagged +-- type and its derivatives. +-- +-- Check that type conversion is defined from a type extension to its +-- parent, and that this parent itself may be a type extension. +-- +-- TEST DESCRIPTION: +-- Declare a root tagged type and two associated primitive subprograms +-- in a package specification (foundation code). +-- +-- Extend the root type with a private extension in a different package +-- specification. Declare a new primitive subprogram for the extension, +-- and override one of the two inherited subprograms. Within the +-- overriding subprogram, utilize type conversion to call the parent's +-- implementation of the same subprogram. Also within the overriding +-- subprogram, call the new primitive subprogram and each inherited +-- subprogram. Declare operations of the private extension which utilize +-- aggregates and equality operators to verify the correctness of the +-- components. +-- +-- Extend the extension with a private extension in the same package +-- specification. Declare a new primitive subprogram for this second +-- extension, and override one of the three inherited subprograms. +-- Within the overriding subprogram, utilize type conversion to call the +-- parent's implementation of the same subprogram. Also within the +-- overriding subprogram, call the new primitive subprogram and each +-- inherited subprogram. Declare operations of the private extension +-- which override the verification operations of its parent. Within +-- these overriding operations, utilize type conversion to call the +-- parent's implementations of the same operations. +-- +-- In the main program, declare objects of the two extended types. +-- For each object, call the overriding subprogram, and verify the +-- correctness of the components by calling the verification operations +-- declared in the second package. +-- +-- TEST FILES: +-- This test consists of the following files: +-- +-- F390A00.A +-- C390A030.A +-- => C390A031.AM +-- +-- +-- CHANGE HISTORY: +-- 06 Dec 94 SAIC ACVC 2.0 +-- 04 Jun 96 SAIC ACVC 2.1: Modified prologue. +-- +--! + +with Report; + +with F390A00; -- Basic alert abstraction. +with C390A030; -- Extended alert abstraction. + +use F390A00; -- Primitive operations of Alert_Type directly visible. + +procedure C390A031 is +begin + + Report.Test ("C390A03", "Primitive operation inheritance by type " & + "extensions: all extensions are private and declared " & + "in same package, but a different package from that " & + "of root type"); + + + -- The case for type F390A00.Alert_Type is tested in C390A01. + -- That subtest is not repeated here. + + + LOW_ALERT_SUBTEST: --------------------------------------------------------- + + declare + Low_Alarm : C390A030.Low_Alert_Type; -- Priv. ext. of tagged type. + use C390A030; -- Primitive operations of extension directly visible. + begin + if not C390A030.Initial_Values_Okay (Low_Alarm) then + Report.Failed ("Wrong initial values for Low_Alert_Type"); + end if; + + Handle (Low_Alarm); + + if C390A030.Bad_Final_Values (Low_Alarm) then + Report.Failed ("Wrong values for Low_Alert_Type after Handle"); + end if; + end Low_Alert_Subtest; + + + -- Check intermediate display counts: + + if F390A00.Display_Count_For /= (Null_Device => 1, + Teletype => 1, + Console => 0, + Big_Screen => 0) + then + Report.Failed ("Wrong display counts after Low_Alert"); + end if; + + + MEDIUM_ALERT_SUBTEST: ------------------------------------------------------ + + declare + Medium_Alarm : C390A030.Medium_Alert_Type; -- Priv. ext. of extension. + use C390A030; -- Primitive operations of extension directly visible. + begin + if not C390A030.Initial_Values_Okay (Medium_Alarm) then + Report.Failed ("Wrong initial values for Medium_Alert_Type"); + end if; + + Handle (Medium_Alarm); + + if C390A030.Bad_Final_Values (Medium_Alarm) then + Report.Failed ("Wrong values for Medium_Alert_Type after Handle"); + end if; + end Medium_Alert_Subtest; + + + -- Check final display counts: + + if F390A00.Display_Count_For /= (Null_Device => 2, + Teletype => 2, + Console => 1, + Big_Screen => 0) + then + Report.Failed ("Wrong display counts after Medium_Alert_Type"); + end if; + + + Report.Result; + +end C390A031; diff --git a/gcc-4.9/gcc/testsuite/ada/acats/tests/c3/c391001.a b/gcc-4.9/gcc/testsuite/ada/acats/tests/c3/c391001.a new file mode 100644 index 000000000..bca752576 --- /dev/null +++ b/gcc-4.9/gcc/testsuite/ada/acats/tests/c3/c391001.a @@ -0,0 +1,329 @@ +-- C391001.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 structures nesting discriminated records as +-- components in record extension are correctly supported. Check +-- for this using limited private structures. +-- Check that record extensions inherit all the visible components +-- of their ancestor types. +-- Check that discriminants are correctly inherited. +-- +-- TEST DESCRIPTION: +-- This test defines a textbook object, a serial number plaque. +-- This object is used in each of several other structures modeled +-- after those used in an existing antenna modeling software system. +-- Record types discriminated and undiscriminated are nested to +-- produce a layered design. Some parametrization is programmatic; +-- some parametrization is data-driven. +-- +-- +-- +-- CHANGE HISTORY: +-- 06 Dec 94 SAIC ACVC 2.0 +-- 19 Dec 94 SAIC Removed RM references from objective text. +-- 19 Apr 95 SAIC Added "limited" to full type def of "Object" +-- +--! + + package C391001_1 is + type Object is tagged limited private; + -- Constructor operation + procedure Create( The_Plaque : in out Object ); + -- Selector operations + function "="( Left_Plaque,Right_Plaque : Object ) return Boolean; + function TC_Match( Left_Plaque : Object; Right_Natural : Natural ) + return Boolean; + function Serial_Number( A_Plaque : Object ) return Natural; + Unserialized : exception; -- Serial_Number called before Create + Reserialized : exception; -- Create called twice + private + type Object is tagged limited record + Serial_Number : Natural := 0; + end record; + end C391001_1; + + package body C391001_1 is + Counter : Natural := 0; + procedure Create( The_Plaque : in out Object ) is + begin + if The_Plaque.Serial_Number = 0 then + Counter := Counter +1; + The_Plaque.Serial_Number := Counter; + else + raise Reserialized; + end if; + end Create; + + function "="( Left_Plaque,Right_Plaque : Object ) return Boolean is + begin + return (Left_Plaque.Serial_Number = Right_Plaque.Serial_Number) + and then -- two uninitialized plates are unequal + (Left_Plaque.Serial_Number /= 0); + end "="; + + function TC_Match( Left_Plaque : Object; Right_Natural : Natural ) + return Boolean is + begin + return (Left_Plaque.Serial_Number = Right_Natural); + end TC_Match; + + function Serial_Number( A_Plaque : Object ) return Natural is + begin + if A_Plaque.Serial_Number = 0 then + raise Unserialized; + end if; + return A_Plaque.Serial_Number; + end Serial_Number; + end C391001_1; + + with C391001_1; + package C391001_2 is -- package Boards is + + package Plaque renames C391001_1; + + type Modes is (Receiving, Transmitting, Standby); + type Link(Mode: Modes := Standby) is record + case Mode is + when Receiving => TC_R : Integer := 100; + when Transmitting => TC_T : Integer := 200; + when Standby => TC_S : Integer := 300; -- TGA, TSA, SSA + end case; + end record; + + type Data_Formats is (S_Band, KU_Band, UHF); + + + type Transceiver(Band: Data_Formats) is tagged limited record + ID : Plaque.Object; + The_Link: Link; + case Band is + when S_Band => TC_S_Band_Data : Integer := 1; -- TGA, SSA + when KU_Band => TC_KU_Band_Data : Integer := 2; -- TSA + when UHF => TC_UHF_Data : Integer := 3; + end case; + end record; + end C391001_2; + + with C391001_1; + with C391001_2; + package C391001_3 is -- package Modules + package Plaque renames C391001_1; + package Boards renames C391001_2; + use type Boards.Modes; + use type Boards.Data_Formats; + + type Command_Formats is ( Set_Compression_Code, + Set_Data_Rate, + Set_Power_State ); + + type Electronics_Module(EBand : Boards.Data_Formats; + The_Command_Format: Command_Formats) + is new Boards.Transceiver(EBand) with record + case The_Command_Format is + when Set_Compression_Code => TC_SCC : Integer := 10; -- SSA + when Set_Data_Rate => TC_SDR : Integer := 20; -- TGA + when Set_Power_State => TC_SPS : Integer := 30; -- TSA + end case; + end record; + end C391001_3; + + with Report; + with C391001_1; + with C391001_2; + with C391001_3; + procedure C391001 is + package Plaque renames C391001_1; + package Boards renames C391001_2; + package Modules renames C391001_3; + use type Boards.Modes; + use type Boards.Data_Formats; + use type Modules.Command_Formats; + + type Azimuth is range 0..359; + + type Ground_Antenna(The_Band : Boards.Data_Formats; + The_Command_Format: Modules.Command_Formats) is + record + ID : Plaque.Object; + Electronics : Modules.Electronics_Module(The_Band,The_Command_Format); + Pointing : Azimuth; + end record; + + type Space_Antenna(The_Band : Boards.Data_Formats := Boards.KU_Band; + The_Command : Modules.Command_Formats + := Modules.Set_Power_State) + is + record + ID : Plaque.Object; + Electronics : Modules.Electronics_Module(The_Band,The_Command); + end record; + + The_Ground_Antenna : Ground_Antenna (Boards.S_Band, + Modules.Set_Data_Rate); + The_Space_Antenna : Space_Antenna; + Space_Station_Antenna : Space_Antenna (Boards.S_Band, + Modules.Set_Compression_Code); + + + procedure Validate( Condition : Boolean; Message: String ) is + begin + if not Condition then + Report.Failed("Failed " & Message ); + end if; + end Validate; + + begin + Report.Test("C391001", "Check nested tagged discriminated " + & "record structures"); + + Plaque.Create( The_Ground_Antenna.ID ); -- 1 + Plaque.Create( The_Ground_Antenna.Electronics.ID ); -- 2 + Plaque.Create( The_Space_Antenna.ID ); -- 3 + Plaque.Create( The_Space_Antenna.Electronics.ID ); -- 4 + Plaque.Create( Space_Station_Antenna.ID ); -- 5 + Plaque.Create( Space_Station_Antenna.Electronics.ID );-- 6 + + The_Ground_Antenna.Pointing := 180; + Validate( The_Ground_Antenna.The_Band = Boards.S_Band, "TGA discr 1" ); + Validate( The_Ground_Antenna.The_Command_Format = Modules.Set_Data_Rate, + "TGA discr 2" ); + Validate( Plaque.TC_Match(The_Ground_Antenna.ID,1), "TGA comp 1" ); + Validate( The_Ground_Antenna.Electronics.EBand = Boards.S_Band, + "TGA comp 2.discr 1" ); + Validate( The_Ground_Antenna.Electronics.The_Command_Format + = Modules.Set_Data_Rate, "TGA comp 2.discr 2" ); + Validate( The_Ground_Antenna.Electronics.TC_SDR = 20, + "TGA comp 2.1" ); + Validate( Plaque.TC_Match( The_Ground_Antenna.Electronics.ID, 2 ), + "TGA comp 2.inher.1" ); + Validate( The_Ground_Antenna.Electronics.The_Link.Mode = Boards.Standby, + "TGA comp 2.inher.2.discr" ); + Validate( The_Ground_Antenna.Electronics.The_Link.TC_S = 300, + "TGA comp 2.inher.2.1" ); + Validate( The_Ground_Antenna.Electronics.TC_S_Band_Data = 1, + "TGA comp 2.inher.3" ); + Validate( The_Ground_Antenna.Pointing = 180, "TGA comp 3" ); + + Validate( The_Space_Antenna.The_Band = Boards.KU_Band, "TSA discr 1"); + Validate( The_Space_Antenna.The_Command = Modules.Set_Power_State, + "TSA discr 2"); + Validate( Plaque.TC_Match(The_Space_Antenna.ID,3), + "TSA comp 1"); + Validate( The_Space_Antenna.Electronics.EBand = Boards.KU_Band, + "TSA comp 2.discr 1"); + Validate( The_Space_Antenna.Electronics.The_Command_Format + = Modules.Set_Power_State, "TSA comp 2.discr 2"); + Validate( Plaque.TC_Match(The_Space_Antenna.Electronics.ID,4), + "TSA comp 2.inher.1"); + Validate( The_Space_Antenna.Electronics.The_Link.Mode = Boards.Standby, + "TSA comp 2.inher.2.discr"); + Validate( The_Space_Antenna.Electronics.The_Link.TC_S = 300, + "TSA comp 2.inher.2.1"); + Validate( The_Space_Antenna.Electronics.TC_KU_Band_Data = 2, + "TSA comp 2.inher.3"); + Validate( The_Space_Antenna.Electronics.TC_SPS = 30, + "TSA comp 2.1"); + + Validate( Space_Station_Antenna.The_Band = Boards.S_Band, "SSA discr 1"); + Validate( Space_Station_Antenna.The_Command = Modules.Set_Compression_Code, + "SSA discr 2"); + Validate( Plaque.TC_Match(Space_Station_Antenna.ID,5), + "SSA comp 1"); + Validate( Space_Station_Antenna.Electronics.EBand = Boards.S_Band, + "SSA comp 2.discr 1"); + Validate( Space_Station_Antenna.Electronics.The_Command_Format + = Modules.Set_Compression_Code, "SSA comp 2.discr 2"); + Validate( Plaque.TC_Match(Space_Station_Antenna.Electronics.ID,6), + "SSA comp 2.inher.1"); + Validate( Space_Station_Antenna.Electronics.The_Link.Mode = Boards.Standby, + "SSA comp 2.inher.2.discr"); + Validate( Space_Station_Antenna.Electronics.The_Link.TC_S = 300, + "SSA comp 2.inher.2.1"); + Validate( Space_Station_Antenna.Electronics.TC_S_Band_Data = 1, + "SSA comp 2.inher.3"); + Validate( Space_Station_Antenna.Electronics.TC_SCC = 10, + "SSA comp 2.1"); + + The_Ground_Antenna.Electronics.TC_SDR := 1001; + The_Ground_Antenna.Electronics.The_Link := +(Boards.Transmitting,2001); + The_Ground_Antenna.Electronics.TC_S_Band_Data := 3001; + The_Ground_Antenna.Pointing := 41; + + The_Space_Antenna.Electronics.The_Link := (Boards.Receiving,1010); + The_Space_Antenna.Electronics.TC_KU_Band_Data := 2020; + The_Space_Antenna.Electronics.TC_SPS := 3030; + + Space_Station_Antenna.Electronics.The_Link + := The_Space_Antenna.Electronics.The_Link; + Space_Station_Antenna.Electronics.The_Link.TC_R := 111; + Space_Station_Antenna.Electronics.TC_S_Band_Data := 222; + Space_Station_Antenna.Electronics.TC_SCC := 333; + + ---------------------------------------------------------------------- + begin -- should fail discriminant check + The_Ground_Antenna.Electronics.TC_SCC := 909; + Report.Failed("Discriminant check, no exception"); + exception + when Constraint_Error => null; + when others => + Report.Failed("Discriminant check, wrong exception"); + end; + + Validate( The_Ground_Antenna.Electronics.TC_SDR = 1001, + "assigned value 1"); + Validate( The_Ground_Antenna.Electronics.The_Link.Mode + = Boards.Transmitting, + "assigned value 2.1"); + Validate( The_Ground_Antenna.Electronics.The_Link.TC_T = 2001, + "assigned value 2.2"); + Validate( The_Ground_Antenna.Electronics.TC_S_Band_Data = 3001, + "assigned value 3"); + Validate( The_Ground_Antenna.Pointing = 41, + "assigned value 4"); + + Validate( The_Space_Antenna.Electronics.The_Link.Mode = Boards.Receiving, + "assigned value 5.1"); + Validate( The_Space_Antenna.Electronics.The_Link.TC_R = 1010, + "assigned value 5.2"); + Validate( The_Space_Antenna.Electronics.TC_KU_Band_Data = 2020, + "assigned value 6"); + Validate( The_Space_Antenna.Electronics.TC_SPS = 3030, + "assigned value 7"); + + Validate( Space_Station_Antenna.Electronics.The_Link.Mode + = Boards.Receiving, + "assigned value 8.1"); + Validate( Space_Station_Antenna.Electronics.The_Link.TC_R = 111, + "assigned value 8.2"); + Validate( Space_Station_Antenna.Electronics.TC_S_Band_Data = 222, + "assigned value 9"); + Validate( Space_Station_Antenna.Electronics.TC_SCC = 333, + "assigned value 10"); + + Report.Result; + +end C391001; diff --git a/gcc-4.9/gcc/testsuite/ada/acats/tests/c3/c391002.a b/gcc-4.9/gcc/testsuite/ada/acats/tests/c3/c391002.a new file mode 100644 index 000000000..77fbfb328 --- /dev/null +++ b/gcc-4.9/gcc/testsuite/ada/acats/tests/c3/c391002.a @@ -0,0 +1,493 @@ +-- C391002.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 structures nesting discriminated records as +-- components in record extension are correctly supported. +-- Check that record extensions inherit all the visible components +-- of their ancestor types. +-- Check that discriminants are correctly inherited. +-- +-- TEST DESCRIPTION: +-- This test defines a simple class hierarchy, where the final +-- derivations exercise the different possible "permissions" available +-- to a designer. Extension aggregates for discriminated types are used +-- to set values of these final types. The key difference between +-- this test and C391001 is that the types are visible, and allow the +-- creation of complex discriminated extension aggregates. Another +-- layer of derivation is present to more robustly check that the +-- inheritance is correctly supported. +-- +-- +-- CHANGE HISTORY: +-- 06 Dec 94 SAIC ACVC 2.0 +-- 16 Dec 94 SAIC Removed offending parenthesis in aggregate +-- extensions, corrected typo: TC_MC SB TC_PC, +-- corrected visibility errors for literals, +-- added qualification for aggregate expressions +-- used in extension aggregates, corrected parameter +-- order in call to Communications.Creator +-- 01 MAY 95 SAIC Removed "limited" from the definition of Mil_Comm +-- 14 OCT 95 SAIC Fixed some value bugs for ACVC 2.0.1 +-- 04 MAR 96 SAIC Altered 3 overambitious extension aggregates +-- 11 APR 96 SAIC Updated documentation for 2.1 +-- 27 FEB 97 PWB.CTA Deleted extra (illegal) component association +--! + +----------------------------------------------------------------- C391002_1 + +package C391002_1 is + + type Object is tagged private; + + -- Constructor operation + procedure Create( The_Plaque : in out Object ); + + -- Selector operations + function TC_Match( Left_Plaque : Object; Right_Natural : Natural ) + return Boolean; + + function Serial_Number( A_Plaque : Object ) return Natural; + + Unserialized : exception; -- Serial_Number called before Create + Reserialized : exception; -- Create called twice + +private + type Object is tagged record + Serial_Number : Natural := 0; + end record; +end C391002_1; + +-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- + +package body C391002_1 is + + Counter : Natural := 0; + + procedure Create( The_Plaque : in out Object ) is + begin + if The_Plaque.Serial_Number = 0 then + Counter := Counter +1; + The_Plaque.Serial_Number := Counter; + else + raise Reserialized; + end if; + end Create; + + function TC_Match( Left_Plaque : Object; Right_Natural : Natural ) + return Boolean is + begin + return (Left_Plaque.Serial_Number = Right_Natural); + end TC_Match; + + function Serial_Number( A_Plaque : Object ) return Natural is + begin + if A_Plaque.Serial_Number = 0 then + raise Unserialized; + end if; + return A_Plaque.Serial_Number; + end Serial_Number; +end C391002_1; + +----------------------------------------------------------------- C391002_2 + +with C391002_1; +package C391002_2 is -- package Boards is + + package Plaque renames C391002_1; + + type Modes is (Receiving, Transmitting, Standby); + type Link(Mode: Modes := Standby) is record + case Mode is + when Receiving => TC_R : Integer := 100; + when Transmitting => TC_T : Integer := 200; + when Standby => TC_S : Integer := 300; -- TGA, TSA, SSA + end case; + end record; + + type Data_Formats is (S_Band, KU_Band, UHF); + + type Transceiver(Band: Data_Formats) is tagged record + ID : Plaque.Object; + The_Link: Link; + case Band is + when S_Band => TC_S_Band_Data : Integer := 1; -- TGA, SSA, Milnet + when KU_Band => TC_KU_Band_Data : Integer := 2; -- TSA, Usenet + when UHF => TC_UHF_Data : Integer := 3; -- Gossip + end case; + end record; +end C391002_2; + +----------------------------------------------------------------- C391002_3 + +with C391002_1; +with C391002_2; +package C391002_3 is -- package Modules + + package Plaque renames C391002_1; + package Boards renames C391002_2; + use type Boards.Modes; + use type Boards.Data_Formats; + + type Command_Formats is ( Set_Compression_Code, + Set_Data_Rate, + Set_Power_State ); + + type Electronics_Module(EBand : Boards.Data_Formats; + The_Command : Command_Formats) + is new Boards.Transceiver(EBand) with record + case The_Command is + when Set_Compression_Code => TC_SCC : Integer := 10; -- SSA, Gossip + when Set_Data_Rate => TC_SDR : Integer := 20; -- TGA, Usenet + when Set_Power_State => TC_SPS : Integer := 30; -- TSA, Milnet + end case; + end record; +end C391002_3; + +----------------------------------------------------------------- C391002_4 + +with C391002_3; +package C391002_4 is -- Communications + package Modules renames C391002_3; + + type Public_Comm is new Modules.Electronics_Module with + record + TC_VC : Integer; + end record; + + type Private_Comm is new Modules.Electronics_Module with private; + + type Mil_Comm is new Modules.Electronics_Module with private; + + procedure Creator( Plugs : in Modules.Electronics_Module; + Gives : out Mil_Comm); + + function Creator( Key : Integer; Plugs : in Modules.Electronics_Module ) + return Private_Comm; + + procedure Setup( It : in out Public_Comm; Value : in Integer ); + procedure Setup( It : in out Private_Comm; Value : in Integer ); + procedure Setup( It : in out Mil_Comm; Value : in Integer ); + + function Selector( It : Public_Comm ) return Integer; + function Selector( It : Private_Comm ) return Integer; + function Selector( It : Mil_Comm ) return Integer; + +private + type Private_Comm is new Modules.Electronics_Module with + record + TC_PC : Integer; + end record; + + type Mil_Comm is new Modules.Electronics_Module with + record + TC_MC : Integer; + end record; +end C391002_4; -- Communications + +-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- + +with Report; +with TCTouch; +package body C391002_4 is -- Communications + + procedure Creator( Plugs : in Modules.Electronics_Module; + Gives : out Mil_Comm) is + begin + Gives := ( Plugs with TC_MC => -1 ); + end Creator; + + function Creator( Key : Integer; Plugs : in Modules.Electronics_Module ) + return Private_Comm is + begin + return ( Plugs with TC_PC => Key ); + end Creator; + + procedure Setup( It : in out Public_Comm; Value : in Integer ) is + begin + It.TC_VC := Value; + TCTouch.Assert( Value = 1, "Public_Comm"); + end Setup; + + procedure Setup( It : in out Private_Comm; Value : in Integer ) is + begin + It.TC_PC := Value; + TCTouch.Assert( Value = 2, "Private_Comm"); + end Setup; + + procedure Setup( It : in out Mil_Comm; Value : in Integer ) is + begin + It.TC_MC := Value; + TCTouch.Assert( Value = 3, "Private_Comm"); + end Setup; + + function Selector( It : Public_Comm ) return Integer is + begin + return It.TC_VC; + end Selector; + + function Selector( It : Private_Comm ) return Integer is + begin + return It.TC_PC; + end Selector; + + function Selector( It : Mil_Comm ) return Integer is + begin + return It.TC_MC; + end Selector; + +end C391002_4; -- Communications + +------------------------------------------------------------------- C391002 + +with Report; +with TCTouch; +with C391002_1; +with C391002_2; +with C391002_3; +with C391002_4; +procedure C391002 is + + package Plaque renames C391002_1; + package Boards renames C391002_2; + package Modules renames C391002_3; + package Communications renames C391002_4; + + procedure Assert( Condition: Boolean; Message: String ) + renames TCTouch.Assert; + + use type Boards.Modes; + use type Boards.Data_Formats; + use type Modules.Command_Formats; + + type Azimuth is range 0..359; + + type Ground_Antenna(The_Band : Boards.Data_Formats; + The_Command : Modules.Command_Formats) is + record + ID : Plaque.Object; + Electronics : Modules.Electronics_Module(The_Band,The_Command); + Pointing : Azimuth; + end record; + + type Space_Antenna(The_Band : Boards.Data_Formats := Boards.KU_Band; + The_Command : Modules.Command_Formats + := Modules.Set_Power_State) + is + record + ID : Plaque.Object; + Electronics : Modules.Electronics_Module(The_Band,The_Command); + end record; + + The_Ground_Antenna : Ground_Antenna (Boards.S_Band, + Modules.Set_Data_Rate); + The_Space_Antenna : Space_Antenna; + Space_Station_Antenna : Space_Antenna (Boards.UHF, + Modules.Set_Compression_Code); + + Gossip : Communications.Public_Comm (Boards.UHF, + Modules.Set_Compression_Code); + Usenet : Communications.Private_Comm (Boards.KU_Band, + Modules.Set_Data_Rate); + Milnet : Communications.Mil_Comm (Boards.S_Band, + Modules.Set_Power_State); + + +begin + + Report.Test("C391002", "Check nested tagged discriminated" + & " record structures"); + + Plaque.Create( The_Ground_Antenna.ID ); -- 1 + Plaque.Create( The_Ground_Antenna.Electronics.ID ); -- 2 + Plaque.Create( The_Space_Antenna.ID ); -- 3 + Plaque.Create( The_Space_Antenna.Electronics.ID ); -- 4 + Plaque.Create( Space_Station_Antenna.ID ); -- 5 + Plaque.Create( Space_Station_Antenna.Electronics.ID );-- 6 + + The_Ground_Antenna := ( The_Band => Boards.S_Band, + The_Command => Modules.Set_Data_Rate, + ID => The_Ground_Antenna.ID, + Electronics => + ( Boards.Transceiver'( + Band => Boards.S_Band, + ID => The_Ground_Antenna.Electronics.ID, + The_Link => ( Mode => Boards.Transmitting, + TC_T => 222 ), + TC_S_Band_Data => 8 ) + with EBand => Boards.S_Band, + The_Command => Modules.Set_Data_Rate, + TC_SDR => 11 ), + Pointing => 270 ); + + The_Space_Antenna := ( The_Band => Boards.S_Band, + The_Command => Modules.Set_Data_Rate, + ID => The_Space_Antenna.ID, + Electronics => + ( Boards.Transceiver'( + Band => Boards.S_Band, + ID => The_Space_Antenna.Electronics.ID, + The_Link => ( Mode => Boards.Transmitting, + TC_T => 456 ), + TC_S_Band_Data => 88 ) + with + EBand => Boards.S_Band, + The_Command => Modules.Set_Data_Rate, + TC_SDR => 42 + ) ); + + Space_Station_Antenna := ( Boards.UHF, Modules.Set_Compression_Code, + Space_Station_Antenna.ID, + ( Boards.Transceiver'( + Boards.UHF, + Space_Station_Antenna.Electronics.ID, + ( Boards.Transmitting, 202 ), + 42 ) + with Boards.UHF, + Modules.Set_Compression_Code, + TC_SCC => 101 + ) ); + + Assert( The_Ground_Antenna.The_Band = Boards.S_Band, "TGA disc 1" ); + Assert( The_Ground_Antenna.The_Command = Modules.Set_Data_Rate, + "TGA disc 2" ); + Assert( Plaque.TC_Match(The_Ground_Antenna.ID,1), "TGA comp 3" ); + Assert( The_Ground_Antenna.Electronics.EBand = Boards.S_Band, + "TGA comp 2.disc 1" ); + Assert( The_Ground_Antenna.Electronics.The_Command + = Modules.Set_Data_Rate, + "TGA comp 2.disc 2" ); + Assert( The_Ground_Antenna.Electronics.TC_SDR = 11, + "TGA comp 2.1" ); + Assert( Plaque.TC_Match( The_Ground_Antenna.Electronics.ID, 2 ), + "TGA comp 2.inher.1" ); + Assert( The_Ground_Antenna.Electronics.The_Link.Mode = Boards.Transmitting, + "TGA comp 2.inher.2.disc" ); + Assert( The_Ground_Antenna.Electronics.The_Link.TC_T = 222, + "TGA comp 2.inher.2.1" ); + Assert( The_Ground_Antenna.Electronics.TC_S_Band_Data = 8, + "TGA comp 2.inher.3" ); + Assert( The_Ground_Antenna.Pointing = 270, "TGA comp 3" ); + + Assert( The_Space_Antenna.The_Band = Boards.S_Band, "TSA disc 1"); + Assert( The_Space_Antenna.The_Command = Modules.Set_Data_Rate, + "TSA disc 2"); + Assert( Plaque.TC_Match(The_Space_Antenna.ID,3), + "TSA comp 1"); + Assert( The_Space_Antenna.Electronics.EBand = Boards.S_Band, + "TSA comp 2.disc 1"); + Assert( The_Space_Antenna.Electronics.The_Command = Modules.Set_Data_Rate, + "TSA comp 2.disc 2"); + Assert( The_Space_Antenna.Electronics.TC_SDR = 42, + "TSA comp 2.1"); + Assert( Plaque.TC_Match(The_Space_Antenna.Electronics.ID,4), + "TSA comp 2.inher.1"); + Assert( The_Space_Antenna.Electronics.The_Link.Mode = Boards.Transmitting, + "TSA comp 2.inher.2.disc"); + Assert( The_Space_Antenna.Electronics.The_Link.TC_T = 456, + "TSA comp 2.inher.2.1"); + Assert( The_Space_Antenna.Electronics.TC_S_Band_Data = 88, + "TSA comp 2.inher.3"); + + Assert( Space_Station_Antenna.The_Band = Boards.UHF, "SSA disc 1"); + Assert( Space_Station_Antenna.The_Command = Modules.Set_Compression_Code, + "SSA disc 2"); + Assert( Plaque.TC_Match(Space_Station_Antenna.ID,5), + "SSA comp 1"); + Assert( Space_Station_Antenna.Electronics.EBand = Boards.UHF, + "SSA comp 2.disc 1"); + Assert( Space_Station_Antenna.Electronics.The_Command + = Modules.Set_Compression_Code, + "SSA comp 2.disc 2"); + Assert( Space_Station_Antenna.Electronics.TC_SCC = 101, + "SSA comp 2.1"); + Assert( Plaque.TC_Match(Space_Station_Antenna.Electronics.ID,6), + "SSA comp 2.inher.1"); + Assert( Space_Station_Antenna.Electronics.The_Link.Mode + = Boards.Transmitting, + "SSA comp 2.inher.2.disc"); + Assert( Space_Station_Antenna.Electronics.The_Link.TC_T = 202, + "SSA comp 2.inher.2.1"); + Assert( Space_Station_Antenna.Electronics.TC_UHF_Data = 42, + "SSA comp 2.inher.3"); + + + The_Space_Antenna := ( The_Band => Boards.S_Band, + The_Command => Modules.Set_Power_State, + ID => The_Space_Antenna.ID, + Electronics => + ( Boards.Transceiver'( + Band => Boards.S_Band, + ID => The_Space_Antenna.Electronics.ID, + The_Link => ( Mode => Boards.Transmitting, + TC_T => 1 ), + TC_S_Band_Data => 5 ) + with + EBand => Boards.S_Band, + The_Command => Modules.Set_Power_State, + TC_SPS => 101 + ) ); + + Communications.Creator( The_Space_Antenna.Electronics, Milnet ); + Assert( Communications.Selector( Milnet ) = -1, "Milnet creator" ); + + Usenet := Communications.Creator( -2, + ( Boards.Transceiver'( + Band => Boards.KU_Band, + ID => The_Space_Antenna.Electronics.ID, + The_Link => ( Boards.Transmitting, TC_T => 101 ), + TC_KU_Band_Data => 395 ) + with Boards.KU_Band, Modules.Set_Data_Rate, 66 ) ); + + Assert( Communications.Selector( Usenet ) = -2, "Usenet creator" ); + + Gossip := ( + Modules.Electronics_Module'( + Boards.Transceiver'( + Band => Boards.UHF, + ID => The_Space_Antenna.Electronics.ID, + The_Link => ( Boards.Transmitting, TC_T => 101 ), + TC_UHF_Data => 395 ) + with + Boards.UHF, Modules.Set_Compression_Code, 66 ) + with + TC_VC => -3 ); + + Assert( Gossip.TC_VC = -3, "Gossip Aggregate" ); + + Communications.Setup( Gossip, 1 ); -- (Boards.UHF, + -- Modules.Set_Compression_Code) + Communications.Setup( Usenet, 2 ); -- (Boards.KU_Band, + -- Modules.Set_Data_Rate) + Communications.Setup( Milnet, 3 ); -- (Boards.S_Band, + -- Modules.Set_Power_State) + + Assert( Communications.Selector( Gossip ) = 1, "Gossip Setup" ); + Assert( Communications.Selector( Usenet ) = 2, "Usenet Setup" ); + Assert( Communications.Selector( Milnet ) = 3, "Milnet Setup" ); + + Report.Result; + +end C391002; diff --git a/gcc-4.9/gcc/testsuite/ada/acats/tests/c3/c392002.a b/gcc-4.9/gcc/testsuite/ada/acats/tests/c3/c392002.a new file mode 100644 index 000000000..41493c227 --- /dev/null +++ b/gcc-4.9/gcc/testsuite/ada/acats/tests/c3/c392002.a @@ -0,0 +1,349 @@ +-- C392002.A +-- +-- Grant of Unlimited Rights +-- +-- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687, +-- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained +-- unlimited rights in the software and documentation contained herein. +-- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making +-- this public release, the Government intends to confer upon all +-- recipients unlimited rights equal to those held by the Government. +-- These rights include rights to use, duplicate, release or disclose the +-- released technical data and computer software in whole or in part, in +-- any manner and for any purpose whatsoever, and to have or permit others +-- to do so. +-- +-- DISCLAIMER +-- +-- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR +-- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED +-- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE +-- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE +-- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A +-- PARTICULAR PURPOSE OF SAID MATERIAL. +--* +-- +-- OBJECTIVE: +-- Check that the use of a class-wide formal parameter allows for the +-- proper dispatching of objects to the appropriate implementation of +-- a primitive operation. Check this in the case where the root tagged +-- type is defined in a generic package, and the type derived from it is +-- defined in that same generic package. +-- +-- TEST DESCRIPTION: +-- Declare a root tagged type, and some associated primitive operations. +-- Extend the root type, and override one or more primitive operations, +-- inheriting the other primitive operations from the root type. +-- Derive from the extended type, again overriding some primitive +-- operations and inheriting others (including some that the parent +-- inherited). +-- Define a subprogram with a class-wide parameter, inside of which is a +-- call on a dispatching primitive operation. These primitive operations +-- modify global variables (the class-wide parameter has mode IN). +-- +-- The following hierarchy of tagged types and primitive operations is +-- utilized in this test: +-- +-- +-- type Vehicle (root) +-- | +-- type Motorcycle +-- | +-- | Operations +-- | Engine_Size +-- | Catalytic_Converter +-- | Emissions_Produced +-- | +-- type Automobile (extended from Motorcycle) +-- | +-- | Operations +-- | (Engine_Size) (inherited) +-- | Catalytic_Converter (overridden) +-- | Emissions_Produced (overridden) +-- | +-- type Truck (extended from Automobile) +-- | +-- | Operations +-- | (Engine_Size) (inherited twice - Motorcycle) +-- | (Catalytic_Converter) (inherited - Automobile) +-- | Emissions_Produced (overridden) +-- +-- +-- In this test, we are concerned with the following selection of dispatching +-- calls, accomplished with the use of a Vehicle'Class IN procedure +-- parameter : +-- +-- \ Type +-- Prim. Op \ Motorcycle Automobile Truck +-- \------------------------------------------------ +-- Engine_Size | X X X +-- Catalytic_Converter | X X X +-- Emissions_Produced | X X X +-- +-- +-- +-- The location of the declaration and derivation of the root and extended +-- types will be varied over a series of tests. Locations of declaration +-- and derivation for a particular test are marked with an asterisk (*). +-- +-- Root type: +-- +-- Declared in package. +-- * Declared in generic package. +-- +-- Extended types: +-- +-- * Derived in parent location. +-- Derived in a nested package. +-- Derived in a nested subprogram. +-- Derived in a nested generic package. +-- Derived in a separate package. +-- Derived in a separate visible child package. +-- Derived in a separate private child package. +-- +-- Primitive Operations: +-- +-- * Procedures with same parameter profile. +-- Procedures with different parameter profile. +-- * Functions with same parameter profile. +-- Functions with different parameter profile. +-- * Mixture of Procedures and Functions. +-- +-- +-- CHANGE HISTORY: +-- 06 Dec 94 SAIC ACVC 2.0 +-- 09 May 96 SAIC Made single-file for 2.1 +-- +--! + +------------------------------------------------------------------- C392002_0 + +-- Declare the root and extended types, along with their primitive +-- operations in a generic package. + +generic + + type Cubic_Inches is range <>; + type Emission_Measure is digits <>; + Emissions_per_Engine_Cubic_Inch : Emission_Measure; + +package C392002_0 is -- package Vehicle_Simulation + + -- + -- Equipment types and their primitive operations. + -- + + -- Root type. + + type Vehicle is abstract tagged + record + Weight : Integer; + Wheels : Positive; + end record; + + -- Abstract operations of type Vehicle. + function Engine_Size (V : in Vehicle) return Cubic_Inches + is abstract; + function Catalytic_Converter (V : in Vehicle) return Boolean + is abstract; + function Emissions_Produced (V : in Vehicle) return Emission_Measure + is abstract; + + -- + + type Motorcycle is new Vehicle with + record + Size_Of_Engine : Cubic_Inches; + end record; + + -- Primitive operations of type Motorcycle. + function Engine_Size (V : in Motorcycle) return Cubic_Inches; + function Catalytic_Converter (V : in Motorcycle) return Boolean; + function Emissions_Produced (V : in Motorcycle) return Emission_Measure; + + -- + + type Automobile is new Motorcycle with + record + Passenger_Capacity : Integer; + end record; + + -- Function Engine_Size inherited from parent (Motorcycle). + -- Primitive operations (Overridden). + function Catalytic_Converter (V : in Automobile) return Boolean; + function Emissions_Produced (V : in Automobile) return Emission_Measure; + + -- + + type Truck is new Automobile with + record + Hauling_Capacity : Natural; + end record; + + -- Function Engine_Size inherited twice. + -- Function Catalytic_Converter inherited from parent (Automobile). + -- Primitive operation (Overridden). + function Emissions_Produced (V : in Truck) return Emission_Measure; + +end C392002_0; + +-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- + +package body c392002_0 is + + -- + -- Primitive operations for Motorcycle. + -- + + function Engine_Size (V : in Motorcycle) return Cubic_Inches is + begin + return (V.Size_Of_Engine); + end Engine_Size; + + + function Catalytic_Converter (V : in Motorcycle) return Boolean is + begin + return (False); + end Catalytic_Converter; + + + function Emissions_Produced (V : in Motorcycle) return Emission_Measure is + begin + return 100.00; + end Emissions_Produced; + + -- + -- Overridden operations for Automobile type. + -- + + function Catalytic_Converter (V : in Automobile) return Boolean is + begin + return (True); + end Catalytic_Converter; + + + function Emissions_Produced (V : in Automobile) return Emission_Measure is + begin + return 200.00; + end Emissions_Produced; + + -- + -- Overridden operation for Truck type. + -- + + function Emissions_Produced (V : in Truck) return Emission_Measure is + begin + return 300.00; + end Emissions_Produced; + +end C392002_0; + +--------------------------------------------------------------------- C392002 + +with C392002_0; -- with Vehicle_Simulation; +with Report; + +procedure C392002 is + + type Decade is (c1970, c1980, c1990); + type Vehicle_Emissions is digits 6; + type Engine_Emissions_by_Decade is array (Decade) of Vehicle_Emissions; + subtype Engine_Size is Integer range 100 .. 1000; + + Five_Tons : constant Natural := 10000; + Catalytic_Converter_Offset : constant Vehicle_Emissions := 0.8; + Truck_Adjustment_Factor : constant Vehicle_Emissions := 1.2; + + + Engine_Emission_Factor : Engine_Emissions_by_Decade := (c1970 => 10.00, + c1980 => 8.00, + c1990 => 5.00); + + -- Instantiate generic package for 1970 simulation. + + package Sim_1970 is new C392002_0 + (Cubic_Inches => Engine_Size, + Emission_Measure => Vehicle_Emissions, + Emissions_Per_Engine_Cubic_Inch => Engine_Emission_Factor (c1970)); + + + -- Declare and initialize vehicle objects. + + Cycle_1970 : Sim_1970.Motorcycle := (Weight => 400, + Wheels => 2, + Size_Of_Engine => 100); + + Auto_1970 : Sim_1970.Automobile := (2000, 4, 500, 5); + + Truck_1970 : Sim_1970.Truck := (Weight => 5000, + Wheels => 18, + Size_Of_Engine => 1000, + Passenger_Capacity => 2, + Hauling_Capacity => Five_Tons); + + -- Function Get_Engine_Size performs a dispatching call on a + -- primitive operation that has been defined for an ancestor type and + -- inherited by each type derived from the ancestor. + + function Get_Engine_Size (V : in Sim_1970.Vehicle'Class) + return Engine_Size is + begin + return (Sim_1970.Engine_Size (V)); -- Dispatch according to tag. + end Get_Engine_Size; + + + -- Function Catalytic_Converter_Present performs a dispatching call on + -- a primitive operation that has been defined for an ancestor type, + -- overridden in the parent extended type, and inherited by the subsequent + -- extended type. + + function Catalytic_Converter_Present (V : in Sim_1970.Vehicle'Class) + return Boolean is + begin + return (Sim_1970.Catalytic_Converter (V)); -- Dispatch according to tag. + end Catalytic_Converter_Present; + + + -- Function Air_Quality_Measure performs a dispatching call on + -- a primitive operation that has been defined for an ancestor type, and + -- overridden in each subsequent extended type. + + function Air_Quality_Measure (V : in Sim_1970.Vehicle'Class) + return Vehicle_Emissions is + begin + return (Sim_1970.Emissions_Produced (V)); -- Dispatch according to tag. + end Air_Quality_Measure; + +-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- + +begin -- Main test procedure. + + Report.Test ("C392002", "Check that the use of a class-wide parameter " + & "allows for proper dispatching where root type " + & "and extended types are declared in the same " + & "generic package" ); + + if (Get_Engine_Size (Cycle_1970) /= 100) or + (Get_Engine_Size (Auto_1970) /= 500) or + (Get_Engine_Size (Truck_1970) /= 1000) + then + Report.Failed ("Failed dispatch to Get_Engine_Size"); + end if; + + if Catalytic_Converter_Present (Cycle_1970) or + not Catalytic_Converter_Present (Auto_1970) or + not Catalytic_Converter_Present (Truck_1970) + then + Report.Failed ("Failed dispatch to Catalytic_Converter_Present"); + end if; + + if ((Air_Quality_Measure (Cycle_1970) /= 100.00) or + (Air_Quality_Measure (Auto_1970) /= 200.00) or + (Air_Quality_Measure (Truck_1970) /= 300.00)) + then + Report.Failed ("Failed dispatch to Air_Quality_Measure"); + end if; + + Report.Result; + +end C392002; diff --git a/gcc-4.9/gcc/testsuite/ada/acats/tests/c3/c392003.a b/gcc-4.9/gcc/testsuite/ada/acats/tests/c3/c392003.a new file mode 100644 index 000000000..d7c5be228 --- /dev/null +++ b/gcc-4.9/gcc/testsuite/ada/acats/tests/c3/c392003.a @@ -0,0 +1,453 @@ +-- C392003.A +-- +-- Grant of Unlimited Rights +-- +-- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687, +-- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained +-- unlimited rights in the software and documentation contained herein. +-- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making +-- this public release, the Government intends to confer upon all +-- recipients unlimited rights equal to those held by the Government. +-- These rights include rights to use, duplicate, release or disclose the +-- released technical data and computer software in whole or in part, in +-- any manner and for any purpose whatsoever, and to have or permit others +-- to do so. +-- +-- DISCLAIMER +-- +-- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR +-- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED +-- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE +-- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE +-- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A +-- PARTICULAR PURPOSE OF SAID MATERIAL. +--* +-- +-- OBJECTIVE: +-- Check that the use of a class-wide formal parameter allows for the +-- proper dispatching of objects to the appropriate implementation of +-- a primitive operation. Check this where the root tagged type is +-- defined in a package, and the extended type is defined in a nested +-- package. +-- +-- TEST DESCRIPTION: +-- Declare a root tagged type, and some associated primitive operations. +-- Extend the root type, and override one or more primitive operations, +-- inheriting the other primitive operations from the root type. +-- Derive from the extended type, again overriding some primitive +-- operations and inheriting others (including some that the parent +-- inherited). +-- Define a subprogram with a class-wide parameter, inside of which is a +-- call on a dispatching primitive operation. These primitive operations +-- modify global variables (the class-wide parameter has mode IN). +-- +-- +-- +-- The following hierarchy of tagged types and primitive operations is +-- utilized in this test: +-- +-- type Bank_Account (root) +-- | +-- | Operations +-- | Increment_Bank_Reserve +-- | Assign_Representative +-- | Increment_Counters +-- | Open +-- | +-- type Savings_Account (extended from Bank_Account) +-- | +-- | Operations +-- | (Increment_Bank_Reserve) (inherited) +-- | Assign_Representative (overridden) +-- | Increment_Counters (overridden) +-- | Open (overridden) +-- | +-- type Preferred_Account (extended from Savings_Account) +-- | +-- | Operations +-- | (Increment_Bank_Reserve) (inherited twice - Bank_Acct.) +-- | (Assign_Representative) (inherited - Savings_Acct.) +-- | Increment_Counters (overridden) +-- | Open (overridden) +-- +-- +-- In this test, we are concerned with the following selection of dispatching +-- calls, accomplished with the use of a Bank_Account'Class IN procedure +-- parameter : +-- +-- \ Type +-- Prim. Op \ Bank_Account Savings_Account Preferred_Account +-- \------------------------------------------------ +-- Increment_Bank_Reserve| X X +-- Assign_Representative | X +-- Increment_Counters | X X X +-- +-- +-- +-- The location of the declaration and derivation of the root and extended +-- types will be varied over a series of tests. Locations of declaration +-- and derivation for a particular test are marked with an asterisk (*). +-- +-- Root type: +-- +-- * Declared in package. +-- Declared in generic package. +-- +-- Extended types: +-- +-- Derived in parent location. +-- * Derived in a nested package. +-- Derived in a nested subprogram. +-- Derived in a nested generic package. +-- Derived in a separate package. +-- Derived in a separate visible child package. +-- Derived in a separate private child package. +-- +-- Primitive Operations: +-- +-- * Procedures with same parameter profile. +-- Procedures with different parameter profile. +-- * Functions with same parameter profile. +-- Functions with different parameter profile. +-- * Mixture of Procedures and Functions. +-- +-- +-- CHANGE HISTORY: +-- 06 Dec 94 SAIC ACVC 2.0 +-- +--! + + + with Report; + + procedure C392003 is + + -- + -- Types and subtypes. + -- + + type Dollar_Amount is new float; + type Interest_Rate is delta 0.001 range 0.000 .. 1.000; + type Account_Types is (Bank, Savings, Preferred, Total); + type Account_Counter is array (Account_Types) of integer; + type Account_Rep is (President, Manager, New_Account_Manager, Teller); + + -- + -- Constants. + -- + + Opening_Balance : constant Dollar_Amount := 100.00; + Current_Rate : constant Interest_Rate := 0.030; + Preferred_Minimum_Balance : constant Dollar_Amount := 1000.00; + + -- + -- Global Variables + -- + + Bank_Reserve : Dollar_Amount := 0.00; + Daily_Representative : Account_Rep := New_Account_Manager; + Number_Of_Accounts : Account_Counter := (Bank => 0, + Savings => 0, + Preferred => 0, + Total => 0); + + -- Root tagged type and primitive operations declared in internal + -- package (Accounts). + -- Extended types (and primitive operations) derived in nested packages. + + --=================================================================-- + + package Accounts is + + -- + -- Root account type and primitive operations. + -- + + -- Root type. + + type Bank_Account is tagged + record + Balance : Dollar_Amount; + end record; + + -- Primitive operations of Bank_Account. + + function Increment_Bank_Reserve (Acct : in Bank_Account) + return Dollar_Amount; + function Assign_Representative (Acct : in Bank_Account) + return Account_Rep; + procedure Increment_Counters (Acct : in Bank_Account); + procedure Open (Acct : in out Bank_Account); + + --=================================================================-- + + package S_And_L is + + -- Declare extended type in a nested package. + + type Savings_Account is new Bank_Account with + record + Rate : Interest_Rate; + end record; + + -- Function Increment_Bank_Reserve inherited from + -- parent (Bank_Account). + + -- Primitive operations (Overridden). + function Assign_Representative (Acct : in Savings_Account) + return Account_Rep; + procedure Increment_Counters (Acct : in Savings_Account); + procedure Open (Acct : in out Savings_Account); + + + --=================================================================-- + + package Premium is + + -- Declare further extended type in a nested package. + + type Preferred_Account is new Savings_Account with + record + Minimum_Balance : Dollar_Amount; + end record; + + -- Function Increment_Bank_Reserve inherited twice. + -- Function Assign_Representative inherited from parent + -- (Savings_Account). + + -- Primitive operation (Overridden). + procedure Increment_Counters (Acct : in Preferred_Account); + procedure Open (Acct : in out Preferred_Account); + + -- Function used to verify Open operation for Preferred_Account + -- objects. + function Verify_Open (Acct : in Preferred_Account) return Boolean; + + end Premium; + + end S_And_L; + + end Accounts; + + --=================================================================-- + + package body Accounts is + + -- + -- Primitive operations for Bank_Account. + -- + + function Increment_Bank_Reserve (Acct : in Bank_Account) + return Dollar_Amount is + begin + return (Bank_Reserve + Acct.Balance); + end Increment_Bank_Reserve; + + function Assign_Representative (Acct : in Bank_Account) + return Account_Rep is + begin + return Account_Rep'(Teller); + end Assign_Representative; + + procedure Increment_Counters (Acct : in Bank_Account) is + begin + Number_Of_Accounts (Bank) := Number_Of_Accounts (Bank) + 1; + Number_Of_Accounts (Total) := Number_Of_Accounts (Total) + 1; + end Increment_Counters; + + procedure Open (Acct : in out Bank_Account) is + begin + Acct.Balance := Opening_Balance; + end Open; + + --=================================================================-- + + package body S_And_L is + + -- + -- Overridden operations for Savings_Account type. + -- + + function Assign_Representative (Acct : in Savings_Account) + return Account_Rep is + begin + return (Manager); + end Assign_Representative; + + procedure Increment_Counters (Acct : in Savings_Account) is + begin + Number_Of_Accounts (Savings) := Number_Of_Accounts (Savings) + 1; + Number_Of_Accounts (Total) := Number_Of_Accounts (Total) + 1; + end Increment_Counters; + + procedure Open (Acct : in out Savings_Account) is + begin + Open (Bank_Account(Acct)); + Acct.Rate := Current_Rate; + Acct.Balance := 2.0 * Opening_Balance; + end Open; + + --=================================================================-- + + package body Premium is + + -- + -- Overridden operations for Preferred_Account type. + -- + + procedure Increment_Counters (Acct : in Preferred_Account) is + begin + Number_Of_Accounts (Preferred) := + Number_Of_Accounts (Preferred) + 1; + Number_Of_Accounts (Total) := + Number_Of_Accounts (Total) + 1; + end Increment_Counters; + + procedure Open (Acct : in out Preferred_Account) is + begin + Open (Savings_Account(Acct)); + Acct.Minimum_Balance := Preferred_Minimum_Balance; + Acct.Balance := Acct.Minimum_Balance; + end Open; + + -- + -- Function used to verify Open operation for Preferred_Account + -- objects. + -- + + function Verify_Open (Acct : in Preferred_Account) + return Boolean is + begin + return (Acct.Balance = Preferred_Minimum_Balance and + Acct.Rate = Current_Rate and + Acct.Minimum_Balance = Preferred_Minimum_Balance); + end Verify_Open; + + end Premium; + + end S_And_L; + + end Accounts; + + --=================================================================-- + + -- Declare account objects. + + B_Account : Accounts.Bank_Account; + S_Account : Accounts.S_And_L.Savings_Account; + P_Account : Accounts.S_And_L.Premium.Preferred_Account; + + -- Procedures to operate on accounts. + -- Each uses a class-wide IN parameter, as well as a call to a + -- dispatching operation. + + -- Function Tabulate_Account performs a dispatching call on a primitive + -- operation that has been overridden for each of the extended types. + + procedure Tabulate_Account (Acct : in Accounts.Bank_Account'Class) is + begin + Accounts.Increment_Counters (Acct); -- Dispatch according to tag. + end Tabulate_Account; + + -- Function Accumulate_Reserve performs a dispatching call on a + -- primitive operation that has been defined for the root type and + -- inherited by each derived type. + + function Accumulate_Reserve (Acct : in Accounts.Bank_Account'Class) + return Dollar_Amount is + begin + -- Dispatch according to tag. + return (Accounts.Increment_Bank_Reserve (Acct)); + end Accumulate_Reserve; + + -- Procedure Resolve_Dispute performs a dispatching call on a primitive + -- operation that has been defined in the root type, overridden in the + -- first derived extended type, and inherited by the subsequent extended + -- type. + + procedure Resolve_Dispute (Acct : in Accounts.Bank_Account'Class) is + begin + -- Dispatch according to tag. + Daily_Representative := Accounts.Assign_Representative (Acct); + end Resolve_Dispute; + + --=================================================================-- + + begin -- Main test procedure. + + Report.Test ("C392003", "Check that the use of a class-wide parameter " & + "allows for proper dispatching where root type " & + "is declared in a nested package, and " & + "subsequent extended types are derived in " & + "further nested packages" ); + + Bank_Account_Subtest: + begin + Accounts.Open (B_Account); + + -- Demonstrate class-wide parameter allowing dispatch by a primitive + -- operation that has been defined for this specific type. + Bank_Reserve := Accumulate_Reserve (Acct => B_Account); + Tabulate_Account (B_Account); + + if (Bank_Reserve /= Opening_Balance) or + (Number_Of_Accounts (Bank) /= 1) or + (Number_Of_Accounts (Total) /= 1) + then + Report.Failed ("Failed in Bank_Account_Subtest"); + end if; + + end Bank_Account_Subtest; + + + Savings_Account_Subtest: + begin + Accounts.S_And_L.Open (Acct => S_Account); + + -- Demonstrate class-wide parameter allowing dispatch by a primitive + -- operation that has been overridden for this extended type. + Resolve_Dispute (Acct => S_Account); + Tabulate_Account (S_Account); + + if (Daily_Representative /= Manager) or + (Number_Of_Accounts (Savings) /= 1) or + (Number_Of_Accounts (Total) /= 2) + then + Report.Failed ("Failed in Savings_Account_Subtest"); + end if; + + end Savings_Account_Subtest; + + + + Preferred_Account_Subtest: + begin + Accounts.S_And_L.Premium.Open (P_Account); + + -- Verify that the correct implementation of Open (overridden) was + -- used for the Preferred_Account object. + if not Accounts.S_And_L.Premium.Verify_Open (P_Account) then + Report.Failed ("Incorrect values for init. Preferred Acct object"); + end if; + + -- Demonstrate class-wide parameter allowing dispatch by a primitive + -- operation that has been twice inherited by this extended type. + Bank_Reserve := Accumulate_Reserve (Acct => P_Account); + + -- Demonstrate class-wide parameter allowing dispatch by a primitive + -- operation that has been overridden for this extended type (the + -- operation was overridden by its parent type as well). + Tabulate_Account (P_Account); + + if Bank_Reserve /= 1100.00 or + Number_Of_Accounts (Preferred) /= 1 or + Number_Of_Accounts (Total) /= 3 + then + Report.Failed ("Failed in Preferred_Account_Subtest"); + end if; + + end Preferred_Account_Subtest; + + Report.Result; + + end C392003; diff --git a/gcc-4.9/gcc/testsuite/ada/acats/tests/c3/c392004.a b/gcc-4.9/gcc/testsuite/ada/acats/tests/c3/c392004.a new file mode 100644 index 000000000..0851db1d2 --- /dev/null +++ b/gcc-4.9/gcc/testsuite/ada/acats/tests/c3/c392004.a @@ -0,0 +1,189 @@ +-- C392004.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 subprograms inherited from tagged derivations, which are +-- subsequently redefined for the derived type, are available to the +-- package defining the new class via view conversion. Check +-- that operations performed on objects using view conversion do not +-- affect the extended fields. Check that visible operations not masked +-- by the deriving package remain available to the client, and do not +-- affect the extended fields. +-- +-- TEST DESCRIPTION: +-- This test declares a tagged type, with a constructor operation, +-- derives a type from that tagged type, and declares a constructor +-- operation which masks the inherited operation. It then tests +-- that the correct constructor is called, and that the extended +-- part of the derived type remains untouched as appropriate. +-- +-- +-- CHANGE HISTORY: +-- 06 Dec 94 SAIC ACVC 2.0 +-- 19 Dec 94 SAIC Removed RM references from objective text. +-- 04 Jan 94 SAIC Fixed objective typo, removed dead code. +-- +--! + +with Report; + +package C392004_1 is + + type Vehicle is tagged private; + + procedure Create ( The_Vehicle : out Vehicle; TC_Flag : Natural ); + procedure Start ( The_Vehicle : in out Vehicle ); + +private + + type Vehicle is tagged record + Engine_On : Boolean; + end record; + +end C392004_1; + +package body C392004_1 is + procedure Create ( The_Vehicle : out Vehicle; TC_Flag : Natural ) is + begin + case TC_Flag is + when 1 => null; -- expected flag for this subprogram + when others => + Report.Failed ("Called Vehicle Create"); + end case; + The_Vehicle := (Engine_On => False); + end Create; + + procedure Start ( The_Vehicle : in out Vehicle ) is + begin + The_Vehicle.Engine_On := True; + end Start; + +end C392004_1; + +---------------------------------------------------------------------------- + +with C392004_1; +package C392004_2 is + + type Car is new C392004_1.Vehicle with record + Convertible : Boolean; + end record; + + -- masking definition + procedure Create( The_Car : out Car; TC_Flag : Natural ); + + type Limo is new Car with null record; + + procedure Create( The_Limo : out Limo; TC_Flag : Natural ); + +end C392004_2; + +---------------------------------------------------------------------------- + +with Report; +package body C392004_2 is + + procedure Create( The_Car : out Car; TC_Flag : Natural ) is + begin + case TC_Flag is + when 2 => null; -- expected flag for this subprogram + when others => Report.Failed ("Called Car Create"); + end case; + C392004_1.Create( C392004_1.Vehicle(The_Car), 1); + The_Car.Convertible := False; + end Create; + + procedure Create( The_Limo : out Limo; TC_Flag : Natural ) is + begin + case TC_Flag is + when 3 => null; -- expected flag for this subprogram + when others => Report.Failed ("Called Limo Create"); + end case; + C392004_1.Create( C392004_1.Vehicle(The_Limo), 1); + The_Limo.Convertible := True; + end Create; + +end C392004_2; + +---------------------------------------------------------------------------- + +with Report; +with C392004_1; use C392004_1; +with C392004_2; use C392004_2; +procedure C392004 is + + My_Car : Car; + Your_Car : Limo; + + procedure TC_Assert( Is_True : Boolean; Message : String ) is + begin + if not Is_True then + Report.Failed (Message); + end if; + end TC_Assert; + +begin -- Main test procedure. + + Report.Test ("C392004", "Check subprogram inheritance & visibility " & + "for derived tagged types" ); + + My_Car.Convertible := False; + Create( Vehicle( My_Car ), 1 ); + TC_Assert( not My_Car.Convertible, "Altered descendent component 1"); + + Create( Your_Car, 3 ); + TC_Assert( Your_Car.Convertible, "Did not set inherited component 2"); + + My_Car.Convertible := True; + Create( Vehicle( My_Car ), 1 ); + TC_Assert( My_Car.Convertible, "Altered descendent component 3"); + + Create( My_Car, 2 ); + TC_Assert( not My_Car.Convertible, "Did not set extending component 4"); + + My_Car.Convertible := False; + Start( Vehicle( My_Car ) ); + TC_Assert( not My_Car.Convertible , "Altered descendent component 5"); + + Start( My_Car ); + TC_Assert( not My_Car.Convertible, "Altered unreferenced component 6"); + + Your_Car.Convertible := False; + Start( Vehicle( Your_Car ) ); + TC_Assert( not Your_Car.Convertible , "Altered descendent component 7"); + + Start( Your_Car ); + TC_Assert( not Your_Car.Convertible, "Altered unreferenced component 8"); + + My_Car.Convertible := True; + Start( Vehicle( My_Car ) ); + TC_Assert( My_Car.Convertible, "Altered descendent component 9"); + + Start( My_Car ); + TC_Assert( My_Car.Convertible, "Altered unreferenced component 10"); + + Report.Result; + +end C392004; diff --git a/gcc-4.9/gcc/testsuite/ada/acats/tests/c3/c392005.a b/gcc-4.9/gcc/testsuite/ada/acats/tests/c3/c392005.a new file mode 100644 index 000000000..be49cd48b --- /dev/null +++ b/gcc-4.9/gcc/testsuite/ada/acats/tests/c3/c392005.a @@ -0,0 +1,367 @@ +-- C392005.A +-- +-- Grant of Unlimited Rights +-- +-- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687, +-- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained +-- unlimited rights in the software and documentation contained herein. +-- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making +-- this public release, the Government intends to confer upon all +-- recipients unlimited rights equal to those held by the Government. +-- These rights include rights to use, duplicate, release or disclose the +-- released technical data and computer software in whole or in part, in +-- any manner and for any purpose whatsoever, and to have or permit others +-- to do so. +-- +-- DISCLAIMER +-- +-- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR +-- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED +-- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE +-- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE +-- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A +-- PARTICULAR PURPOSE OF SAID MATERIAL. +--* +-- +-- OBJECTIVE: +-- Check that, for an implicitly declared dispatching operation that is +-- overridden, the body executed is the body for the overriding +-- subprogram, even if the overriding occurs in a private part. +-- +-- Check for the case where the overriding operations are declared in a +-- public child unit of the package declaring the parent type, and the +-- descendant type is a private extension. +-- +-- Check for both dispatching and nondispatching calls. +-- +-- +-- TEST DESCRIPTION: +-- Consider: +-- +-- package Parent is +-- type Root is tagged ... +-- procedure Vis_Op (P: Root); +-- private +-- procedure Pri_Op (P: Root); +-- end Parent; +-- +-- package Parent.Child is +-- type Derived is new Root with private; +-- -- Implicit Vis_Op (P: Derived) declared here. +-- +-- procedure Pri_Op (P: Derived); -- (A) +-- ... +-- private +-- type Derived is new Root with record... +-- -- Implicit Pri_Op (P: Derived) declared here. + +-- procedure Vis_Op (P: Derived); -- (B) +-- ... +-- end Parent.Child; +-- +-- Type Derived inherits both Vis_Op and Pri_Op from the ancestor type +-- Root. Note, however, that Vis_Op is implicitly declared in the visible +-- part, whereas Pri_Op is implicitly declared in the private part +-- (inherited subprograms for a private extension are implicitly declared +-- after the private_extension_declaration if the corresponding +-- declaration from the ancestor is visible at that place; otherwise the +-- inherited subprogram is not declared for the private extension, +-- although it might be for the full type). +-- +-- Even though Root's version of Pri_Op hasn't been implicitly declared +-- for Derived at the time Derived's version of Pri_Op has been +-- explicitly declared, the explicit Pri_Op still overrides the implicit +-- version. +-- Also, even though the explicit Vis_Op for Derived is declared in the +-- private part it still overrides the implicit version declared in the +-- visible part. Calls with tag Derived will execute (A) and (B). +-- +-- +-- CHANGE HISTORY: +-- 06 Dec 94 SAIC ACVC 2.0 +-- 26 Nov 96 SAIC Improved for ACVC 2.1 +-- +--! + +package C392005_0 is + + type Remote_Camera is tagged private; + + type Depth_Of_Field is range 5 .. 100; + type Shutter_Speed is (One, Two_Fifty, Four_Hundred, Thousand); + type Aperture is (Eight, Sixteen, Thirty_Two); + + -- ...Other declarations. + + procedure Focus (Cam : in out Remote_Camera; + Depth : in Depth_Of_Field); + + procedure Self_Test (C: in out Remote_Camera'Class); + + -- ...Other operations. + + function TC_Get_Depth (C: Remote_Camera) return Depth_Of_Field; + function TC_Get_Speed (C: Remote_Camera) return Shutter_Speed; + +private + + type Remote_Camera is tagged record + DOF : Depth_Of_Field := 10; + Shutter: Shutter_Speed := One; + FStop : Aperture := Eight; + end record; + + procedure Set_Shutter_Speed (C : in out Remote_Camera; + Speed : in Shutter_Speed); + + -- For the basic remote camera, shutter speed might be set as a function of + -- focus perhaps, thus it is declared as a private operation (usable + -- only internally within the abstraction). + + function Set_Aperture (C : Remote_Camera) return Aperture; + +end C392005_0; + + + --==================================================================-- + + +package body C392005_0 is + + procedure Focus (Cam : in out Remote_Camera; + Depth : in Depth_Of_Field) is + begin + -- Artificial for testing purposes. + Cam.DOF := 46; + end Focus; + + ----------------------------------------------------------- + procedure Set_Shutter_Speed (C : in out Remote_Camera; + Speed : in Shutter_Speed) is + begin + -- Artificial for testing purposes. + C.Shutter := Thousand; + end Set_Shutter_Speed; + + ----------------------------------------------------------- + function Set_Aperture (C : Remote_Camera) return Aperture is + begin + -- Artificial for testing purposes. + return Thirty_Two; + end Set_Aperture; + + ----------------------------------------------------------- + procedure Self_Test (C: in out Remote_Camera'Class) is + TC_Dummy_Depth : constant Depth_Of_Field := 23; + TC_Dummy_Speed : constant Shutter_Speed := Four_Hundred; + begin + + -- Test focus at various depths: + Focus(C, TC_Dummy_Depth); + -- ...Additional calls to Focus. + + -- Test various shutter speeds: + Set_Shutter_Speed(C, TC_Dummy_Speed); + -- ...Additional calls to Set_Shutter_Speed. + + end Self_Test; + + ----------------------------------------------------------- + function TC_Get_Depth (C: Remote_Camera) return Depth_Of_Field is + begin + return C.DOF; + end TC_Get_Depth; + + ----------------------------------------------------------- + function TC_Get_Speed (C: Remote_Camera) return Shutter_Speed is + begin + return C.Shutter; + end TC_Get_Speed; + +end C392005_0; + + --==================================================================-- + + +package C392005_0.C392005_1 is + + type Auto_Speed is new Remote_Camera with private; + + + -- procedure Focus (C : in out Auto_Speed; -- Implicitly declared + -- Depth : in Depth_Of_Field) -- here. + + -- For the improved remote camera, shutter speed can be set manually, + -- so it is declared as a public operation. + + -- The order of declarations for Set_Aperture and Set_Shutter_Speed are + -- reversed from the original declarations to trap potential compiler + -- problems related to subprogram ordering. + + function Set_Aperture (C : Auto_Speed) return Aperture; -- Overrides + -- inherited op. + + procedure Set_Shutter_Speed (C : in out Auto_Speed; -- Overrides + Speed : in Shutter_Speed);-- inherited op. + + -- Set_Shutter_Speed and Set_Aperture override the operations inherited + -- from the parent, even though the inherited operations are not implicitly + -- declared until the private part below. + + type New_Camera is private; + + function TC_Get_Aper (C: New_Camera) return Aperture; + + -- ...Other operations. + +private + type Film_Speed is (One_Hundred, Two_Hundred, Four_Hundred); + + type Auto_Speed is new Remote_Camera with record + ASA : Film_Speed; + end record; + + -- procedure Set_Shutter_Speed (C : in out Auto_Speed; -- Implicitly + -- Speed : in Shutter_Speed) -- declared + -- here. + + -- function Set_Aperture (C : Auto_Speed) return Aperture; -- Implicitly + -- declared. + + procedure Focus (C : in out Auto_Speed; -- Overrides + Depth : in Depth_Of_Field); -- inherited op. + + -- For the improved remote camera, perhaps the focusing algorithm is + -- different, so the original Focus operation is overridden here. + + Auto_Camera : Auto_Speed; + + type New_Camera is record + Aper : Aperture := Set_Aperture (Auto_Camera); -- Calls the overridden, + end record; -- not the inherited op. + +end C392005_0.C392005_1; + + + --==================================================================-- + + +package body C392005_0.C392005_1 is + + procedure Focus (C : in out Auto_Speed; + Depth : in Depth_Of_Field) is + begin + -- Artificial for testing purposes. + C.DOF := 57; + end Focus; + + --------------------------------------------------------------- + procedure Set_Shutter_Speed (C : in out Auto_Speed; + Speed : in Shutter_Speed) is + begin + -- Artificial for testing purposes. + C.Shutter := Two_Fifty; + end Set_Shutter_Speed; + + ----------------------------------------------------------- + function Set_Aperture (C : Auto_Speed) return Aperture is + begin + -- Artificial for testing purposes. + return Sixteen; + end Set_Aperture; + + ----------------------------------------------------------- + function TC_Get_Aper (C: New_Camera) return Aperture is + begin + return C.Aper; + end TC_Get_Aper; + +end C392005_0.C392005_1; + + + --==================================================================-- + + +with C392005_0.C392005_1; + +with Report; + +procedure C392005 is + Basic_Camera : C392005_0.Remote_Camera; + Auto_Camera1 : C392005_0.C392005_1.Auto_Speed; + Auto_Camera2 : C392005_0.C392005_1.Auto_Speed; + Auto_Depth : C392005_0.Depth_Of_Field := 67; + New_Camera1 : C392005_0.C392005_1.New_Camera; + TC_Expected_Basic_Depth : constant C392005_0.Depth_Of_Field := 46; + TC_Expected_Auto_Depth : constant C392005_0.Depth_Of_Field := 57; + TC_Expected_Basic_Speed : constant C392005_0.Shutter_Speed + := C392005_0.Thousand; + TC_Expected_Auto_Speed : constant C392005_0.Shutter_Speed + := C392005_0.Two_Fifty; + TC_Expected_New_Aper : constant C392005_0.Aperture + := C392005_0.Sixteen; + + use type C392005_0.Depth_Of_Field; + use type C392005_0.Shutter_Speed; + use type C392005_0.Aperture; + +begin + Report.Test ("C392005", "Dispatching for overridden primitive " & + "subprograms: private extension declared in child unit, " & + "parent is tagged private whose full view is tagged record"); + +-- Call the class-wide operation for Remote_Camera'Class, which itself makes +-- dispatching calls to Focus and Set_Shutter_Speed: + + + -- For an object of type Remote_Camera, the dispatching calls should + -- dispatch to the bodies declared for the root type: + + C392005_0.Self_Test(Basic_Camera); + + if C392005_0.TC_Get_Depth (Basic_Camera) /= TC_Expected_Basic_Depth + or else C392005_0.TC_Get_Speed (Basic_Camera) /= TC_Expected_Basic_Speed + then + Report.Failed ("Calls dispatched incorrectly for root type"); + end if; + + + -- For an object of type Auto_Speed, the dispatching calls should + -- dispatch to the bodies declared for the derived type: + + C392005_0.Self_Test(Auto_Camera1); + + if C392005_0.C392005_1.TC_Get_Depth(Auto_Camera1) /= TC_Expected_Auto_Depth + + or + C392005_0.C392005_1.TC_Get_Speed(Auto_Camera1) /= TC_Expected_Auto_Speed + then + Report.Failed ("Calls dispatched incorrectly for derived type"); + end if; + + -- For an object of type Auto_Speed, a non-dispatching call to Focus should + + -- execute the body declared for the derived type (even through it is + -- declared in the private part). + + C392005_0.C392005_1.Focus (Auto_Camera2, Auto_Depth); + + if C392005_0.C392005_1.TC_Get_Depth(Auto_Camera2) /= TC_Expected_Auto_Depth + + then + Report.Failed ("Non-dispatching call to privately overriding " & + "subprogram executed the wrong body"); + end if; + + -- For an object of type New_Camera, the initialization using Set_Ap + -- should execute the overridden body, not the inherited one. + + if C392005_0.C392005_1.TC_Get_Aper (New_Camera1) /= TC_Expected_New_Aper + then + Report.Failed ("Non-dispatching call to visible overriding " & + "subprogram executed the wrong body"); + end if; + + Report.Result; + +end C392005; diff --git a/gcc-4.9/gcc/testsuite/ada/acats/tests/c3/c392008.a b/gcc-4.9/gcc/testsuite/ada/acats/tests/c3/c392008.a new file mode 100644 index 000000000..27b4e2a86 --- /dev/null +++ b/gcc-4.9/gcc/testsuite/ada/acats/tests/c3/c392008.a @@ -0,0 +1,401 @@ +-- C392008.A +-- +-- Grant of Unlimited Rights +-- +-- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687, +-- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained +-- unlimited rights in the software and documentation contained herein. +-- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making +-- this public release, the Government intends to confer upon all +-- recipients unlimited rights equal to those held by the Government. +-- These rights include rights to use, duplicate, release or disclose the +-- released technical data and computer software in whole or in part, in +-- any manner and for any purpose whatsoever, and to have or permit others +-- to do so. +-- +-- DISCLAIMER +-- +-- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR +-- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED +-- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE +-- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE +-- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A +-- PARTICULAR PURPOSE OF SAID MATERIAL. +--* +-- +-- OBJECTIVE: +-- Check that the use of a class-wide formal parameter allows for the +-- proper dispatching of objects to the appropriate implementation of +-- a primitive operation. Check this for the case where the root tagged +-- type is defined in a package and the extended type is defined in a +-- dependent package. +-- +-- TEST DESCRIPTION: +-- Declare a root tagged type, and some associated primitive operations, +-- in a visible library package. +-- Extend the root type in another visible library package, and override +-- one or more primitive operations, inheriting the other primitive +-- operations from the root type. +-- Derive from the extended type in yet another visible library package, +-- again overriding some primitive operations and inheriting others +-- (including some that the parent inherited). +-- Define subprograms with class-wide parameters, inside of which is a +-- call on a dispatching primitive operation. These primitive +-- operations modify the objects of the specific class passed as actuals +-- to the class-wide formal parameter (class-wide formal parameter has +-- mode IN OUT). +-- +-- The following hierarchy of tagged types and primitive operations is +-- utilized in this test: +-- +-- package Bank +-- type Account (root) +-- | +-- | Operations +-- | proc Deposit +-- | proc Withdrawal +-- | func Balance +-- | proc Service_Charge +-- | proc Add_Interest +-- | proc Open +-- | +-- package Checking +-- type Account (extended from Bank.Account) +-- | +-- | Operations +-- | proc Deposit (inherited) +-- | proc Withdrawal (inherited) +-- | func Balance (inherited) +-- | proc Service_Charge (inherited) +-- | proc Add_Interest (inherited) +-- | proc Open (overridden) +-- | +-- package Interest_Checking +-- type Account (extended from Checking.Account) +-- | +-- | Operations +-- | proc Deposit (inherited twice - Bank.Acct.) +-- | proc Withdrawal (inherited twice - Bank.Acct.) +-- | func Balance (inherited twice - Bank.Acct.) +-- | proc Service_Charge (inherited twice - Bank.Acct.) +-- | proc Add_Interest (overridden) +-- | proc Open (overridden) +-- | +-- +-- In this test, we are concerned with the following selection of dispatching +-- calls, accomplished with the use of a Bank.Account'Class IN OUT formal +-- parameter : +-- +-- \ Type +-- Prim. Op \ Bank.Account Checking.Account Interest_Checking.Account +-- \--------------------------------------------------------- + +-- Service_Charge | X X X +-- Add_Interest | X X X +-- Open | X X X +-- +-- +-- +-- The location of the declaration of the root and derivation of extended +-- types will be varied over a series of tests. Locations of declaration +-- and derivation for a particular test are marked with an asterisk (*). +-- +-- Root type: +-- +-- * Declared in package. +-- Declared in generic package. +-- +-- Extended types: +-- +-- Derived in parent location. +-- Derived in a nested package. +-- Derived in a nested subprogram. +-- Derived in a nested generic package. +-- * Derived in a separate package. +-- Derived in a separate visible child package. +-- Derived in a separate private child package. +-- +-- Primitive Operations: +-- +-- * Procedures with same parameter profile. +-- Procedures with different parameter profile. +-- Functions with same parameter profile. +-- Functions with different parameter profile. +-- Mixture of Procedures and Functions. +-- +-- +-- TEST FILES: +-- This test depends on the following foundation code: +-- +-- C392008_0.A +-- +-- +-- CHANGE HISTORY: +-- 06 Dec 94 SAIC ACVC 2.0 +-- 20 Nov 95 SAIC C392B04 became C392008 for ACVC 2.0.1 +-- +--! + +----------------------------------------------------------------- C392008_0 + +package C392008_0 is -- package Bank + + type Dollar_Amount is range -30_000..30_000; + + type Account is tagged + record + Current_Balance: Dollar_Amount; + end record; + + -- Primitive operations. + + procedure Deposit (A : in out Account; + X : in Dollar_Amount); + procedure Withdrawal (A : in out Account; + X : in Dollar_Amount); + function Balance (A : in Account) return Dollar_Amount; + procedure Service_Charge (A : in out Account); + procedure Add_Interest (A : in out Account); + procedure Open (A : in out Account); + +end C392008_0; + +-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- + +package body C392008_0 is + + -- Primitive operations for type Account. + + procedure Deposit (A : in out Account; + X : in Dollar_Amount) is + begin + A.Current_Balance := A.Current_Balance + X; + end Deposit; + + procedure Withdrawal(A : in out Account; + X : in Dollar_Amount) is + begin + A.Current_Balance := A.Current_Balance - X; + end Withdrawal; + + function Balance (A : in Account) return Dollar_Amount is + begin + return (A.Current_Balance); + end Balance; + + procedure Service_Charge (A : in out Account) is + begin + A.Current_Balance := A.Current_Balance - 5_00; + end Service_Charge; + + procedure Add_Interest (A : in out Account) is + Interest_On_Account : Dollar_Amount := 0_00; + begin + A.Current_Balance := A.Current_Balance + Interest_On_Account; + end Add_Interest; + + procedure Open (A : in out Account) is + Initial_Deposit : Dollar_Amount := 10_00; + begin + A.Current_Balance := Initial_Deposit; + end Open; + +end C392008_0; + +----------------------------------------------------------------- C392008_1 + +with C392008_0; -- package Bank + +package C392008_1 is -- package Checking + + package Bank renames C392008_0; + + type Account is new Bank.Account with + record + Overdraft_Fee : Bank.Dollar_Amount; + end record; + + -- Overridden primitive operation. + + procedure Open (A : in out Account); + + -- Inherited primitive operations. + -- procedure Deposit (A : in out Account; + -- X : in Bank.Dollar_Amount); + -- procedure Withdrawal (A : in out Account; + -- X : in Bank.Dollar_Amount); + -- function Balance (A : in Account) return Bank.Dollar_Amount; + -- procedure Service_Charge (A : in out Account); + -- procedure Add_Interest (A : in out Account); + +end C392008_1; + +-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- + +package body C392008_1 is + + -- Overridden primitive operation. + + procedure Open (A : in out Account) is + Check_Guarantee : Bank.Dollar_Amount := 10_00; + Initial_Deposit : Bank.Dollar_Amount := 20_00; + begin + A.Current_Balance := Initial_Deposit; + A.Overdraft_Fee := Check_Guarantee; + end Open; + +end C392008_1; + +----------------------------------------------------------------- C392008_2 + +with C392008_0; -- with Bank; +with C392008_1; -- with Checking; + +package C392008_2 is -- package Interest_Checking + + package Bank renames C392008_0; + package Checking renames C392008_1; + + subtype Interest_Rate is Bank.Dollar_Amount range 0..100; -- was digits 4; + + Current_Rate : Interest_Rate := 0_02; + + type Account is new Checking.Account with + record + Rate : Interest_Rate; + end record; + + -- Overridden primitive operations. + + procedure Add_Interest (A : in out Account); + procedure Open (A : in out Account); + + -- "Twice" inherited primitive operations (from Bank.Account) + -- procedure Deposit (A : in out Account; + -- X : in Bank.Dollar_Amount); + -- procedure Withdrawal (A : in out Account; + -- X : in Bank.Dollar_Amount); + -- function Balance (A : in Account) return Bank.Dollar_Amount; + -- procedure Service_Charge (A : in out Account); + +end C392008_2; + +-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- + +package body C392008_2 is + + -- Overridden primitive operations. + + procedure Add_Interest (A : in out Account) is + Interest_On_Account : Bank.Dollar_Amount + := Bank.Dollar_Amount( Bank."*"( A.Current_Balance, A.Rate )); + begin + A.Current_Balance := Bank."+"( A.Current_Balance, Interest_On_Account); + end Add_Interest; + + procedure Open (A : in out Account) is + Initial_Deposit : Bank.Dollar_Amount := 30_00; + begin + Checking.Open (Checking.Account (A)); + A.Current_Balance := Initial_Deposit; + A.Rate := Current_Rate; + end Open; + +end C392008_2; + +------------------------------------------------------------------- C392008 + +with C392008_0; use C392008_0; -- package Bank +with C392008_1; use C392008_1; -- package Checking; +with C392008_2; use C392008_2; -- package Interest_Checking; +with Report; + +procedure C392008 is + + package Bank renames C392008_0; + package Checking renames C392008_1; + package Interest_Checking renames C392008_2; + + B_Acct : Bank.Account; + C_Acct : Checking.Account; + IC_Acct : Interest_Checking.Account; + + -- + -- Define procedures with class-wide formal parameters of mode IN OUT. + -- + + -- This procedure will perform a dispatching call on the + -- overridden primitive operation Open. + + procedure New_Account (Acct : in out Bank.Account'Class) is + begin + Open (Acct); -- Dispatch according to tag of class-wide parameter. + end New_Account; + + -- This procedure will perform a dispatching call on the inherited + -- primitive operation (for all types derived from the root Bank.Account) + -- Service_Charge. + + procedure Apply_Service_Charge (Acct: in out Bank.Account'Class) is + begin + Service_Charge (Acct); -- Dispatch according to tag of class-wide parm. + end Apply_Service_Charge; + + -- This procedure will perform a dispatching call on the + -- inherited/overridden primitive operation Add_Interest. + + procedure Annual_Interest (Acct: in out Bank.Account'Class) is + begin + Add_Interest (Acct); -- Dispatch according to tag of class-wide parm. + end Annual_Interest; + +begin + + Report.Test ("C392008", "Check that the use of a class-wide formal " & + "parameter allows for the proper dispatching " & + "of objects to the appropriate implementation " & + "of a primitive operation"); + + -- Check the dispatch to primitive operations overridden for each + -- extended type. + New_Account (B_Acct); + New_Account (C_Acct); + New_Account (IC_Acct); + + if (B_Acct.Current_Balance /= 10_00) or + (C_Acct.Current_Balance /= 20_00) or + (IC_Acct.Current_Balance /= 30_00) + then + Report.Failed ("Failed dispatch to multiply overridden prim. oper."); + end if; + + + Annual_Interest (B_Acct); + Annual_Interest (C_Acct); + Annual_Interest (IC_Acct); -- Check the dispatch to primitive operation + -- overridden from a parent type which inherited + -- the operation from the root type. + if (B_Acct.Current_Balance /= 10_00) or + (C_Acct.Current_Balance /= 20_00) or + (IC_Acct.Current_Balance /= 90_00) + then + Report.Failed ("Failed dispatch to overridden primitive operation"); + end if; + + + Apply_Service_Charge (Acct => B_Acct); + Apply_Service_Charge (Acct => C_Acct); + Apply_Service_Charge (Acct => IC_Acct); -- Check the dispatch to a + -- primitive operation twice + -- inherited from the root + -- tagged type. + if (B_Acct.Current_Balance /= 5_00) or + (C_Acct.Current_Balance /= 15_00) or + (IC_Acct.Current_Balance /= 85_00) + then + Report.Failed ("Failed dispatch to Apply_Service_Charge"); + end if; + + Report.Result; + +end C392008; diff --git a/gcc-4.9/gcc/testsuite/ada/acats/tests/c3/c392010.a b/gcc-4.9/gcc/testsuite/ada/acats/tests/c3/c392010.a new file mode 100644 index 000000000..ec168780c --- /dev/null +++ b/gcc-4.9/gcc/testsuite/ada/acats/tests/c3/c392010.a @@ -0,0 +1,512 @@ +-- C392010.A +-- +-- Grant of Unlimited Rights +-- +-- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687, +-- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained +-- unlimited rights in the software and documentation contained herein. +-- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making +-- this public release, the Government intends to confer upon all +-- recipients unlimited rights equal to those held by the Government. +-- These rights include rights to use, duplicate, release or disclose the +-- released technical data and computer software in whole or in part, in +-- any manner and for any purpose whatsoever, and to have or permit others +-- to do so. +-- +-- DISCLAIMER +-- +-- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR +-- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED +-- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE +-- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE +-- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A +-- PARTICULAR PURPOSE OF SAID MATERIAL. +--* +-- +-- OBJECTIVE: +-- Check that a subprogram dispatches correctly with a controlling +-- access parameter. Check that a subprogram dispatches correctly +-- when it has access parameters that are not controlling. +-- Check with and without default expressions. +-- +-- TEST DESCRIPTION: +-- The three packages define layers of tagged types. The root tagged +-- type contains a character value used to check that the right object +-- got passed to the right routine. Each subprogram has a unique +-- TCTouch tag, upper case values are used for subprograms, lower case +-- values are used for object values. +-- +-- Notes on style: the "tagged" comment lines --I and --A represent +-- commentary about what gets inherited and what becomes abstract, +-- respectively. The author felt these to be necessary with this test +-- to reduce some of the additional complexities. +-- +--3.9.2(16,17,18,20);6.0 +-- +-- CHANGE HISTORY: +-- 22 SEP 95 SAIC Initial version +-- 22 APR 96 SAIC Revised for 2.1 +-- 05 JAN 98 EDS Change return type of C392010_2.Func_W_Non to make +-- it override. +-- 21 JUN 00 RLB Changed expected result to reflect the appropriate +-- value of the default expression. +-- 20 JUL 00 RLB Removed entire call pending resolution by the ARG. + +--! + +----------------------------------------------------------------- C392010_0 + +package C392010_0 is + + -- define a root tagged type + type Tagtype_Level_0 is tagged record + Ch_Item : Character; + end record; + + type Access_Procedure is access procedure( P: Tagtype_Level_0 ); + + procedure Proc_1( P: Tagtype_Level_0 ); + + procedure Proc_2( P: Tagtype_Level_0 ); + + function A_Default_Value return Tagtype_Level_0; + + procedure Proc_w_Ap_and_Cp( AP : Access_Procedure; + Cp : Tagtype_Level_0 ); + -- has both access procedure and controlling parameter + + procedure Proc_w_Ap_and_Cp_w_Def( AP : Access_Procedure := Proc_2'Access; + Cp : Tagtype_Level_0 + := A_Default_Value ); ------------ z + -- has both access procedure and controlling parameter with defaults + + -- for the objective: +-- Check that access parameters may be controlling. + + procedure Proc_w_Cp_Ap( Cp_Ap : access Tagtype_Level_0 ); + -- has access parameter that is controlling + + function Func_w_Cp_Ap_and_Cr( Cp_Ap : access Tagtype_Level_0 ) + return Tagtype_Level_0; + -- has access parameter that is controlling, and controlling result + + Level_0_Global_Object : aliased Tagtype_Level_0 + := ( Ch_Item => 'a' ); ---------------------------- a + +end C392010_0; + +-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- + +with TCTouch; +package body C392010_0 is + + procedure Proc_1( P: Tagtype_Level_0 ) is + begin + TCTouch.Touch('A'); --------------------------------------------------- A + TCTouch.Touch(P.Ch_Item); -- depends on the value passed -------------- ? + end Proc_1; + + procedure Proc_2( P: Tagtype_Level_0 ) is + begin + TCTouch.Touch('B'); --------------------------------------------------- B + TCTouch.Touch(P.Ch_Item); -- depends on the value passed -------------- ? + end Proc_2; + + function A_Default_Value return Tagtype_Level_0 is + begin + return (Ch_Item => 'z'); ---------------------------------------------- z + end A_Default_Value; + + procedure Proc_w_Ap_and_Cp( Ap : Access_Procedure; + Cp : Tagtype_Level_0 ) is + begin + TCTouch.Touch('C'); --------------------------------------------------- C + Ap.all( Cp ); + end Proc_w_Ap_and_Cp; + + procedure Proc_w_Ap_and_Cp_w_Def( AP : Access_Procedure := Proc_2'Access; + Cp : Tagtype_Level_0 + := A_Default_Value ) is + begin + TCTouch.Touch('D'); --------------------------------------------------- D + Ap.all( Cp ); + end Proc_w_Ap_and_Cp_w_Def; + + procedure Proc_w_Cp_Ap( Cp_Ap : access Tagtype_Level_0 ) is + begin + TCTouch.Touch('E'); --------------------------------------------------- E + TCTouch.Touch(Cp_Ap.Ch_Item); -- depends on the value passed ---------- ? + end Proc_w_Cp_Ap; + + function Func_w_Cp_Ap_and_Cr( Cp_Ap : access Tagtype_Level_0 ) + return Tagtype_Level_0 is + begin + TCTouch.Touch('F'); --------------------------------------------------- F + TCTouch.Touch(Cp_Ap.Ch_Item); -- depends on the value passed ---------- ? + return ( Ch_Item => 'b' ); -------------------------------------------- b + end Func_w_Cp_Ap_and_Cr; + +end C392010_0; + +----------------------------------------------------------------- C392010_1 + +with C392010_0; +package C392010_1 is + + type Tagtype_Level_1 is new C392010_0.Tagtype_Level_0 with record + Int_Item : Integer; + end record; + + type Access_Tagtype_Level_1 is access all Tagtype_Level_1'Class; + + -- the following procedures are inherited by the above declaration: + --I procedure Proc_1( P: Tagtype_Level_1 ); + --I + --I procedure Proc_2( P: Tagtype_Level_1 ); + --I + --I procedure Proc_w_Ap_and_Cp( AP : C392010_0.Access_Procedure; + --I Cp : Tagtype_Level_1 ); + --I + --I procedure Proc_w_Ap_and_Cp_w_Def + --I ( AP : C392010_0.Access_Procedure := Proc_2'Access; + --I Cp : Tagtype_Level_1 := A_Default_Value ); + --I + --I procedure Proc_w_Cp_Ap( Cp_Ap : access Tagtype_Level_1 ); + --I + + -- the following functions become abstract due to the above declaration: + --A function A_Default_Value return Tagtype_Level_1; + --A + --A function Func_w_Cp_Ap_and_Cr( Cp_Ap : access Tagtype_Level_1 ) + --A return Tagtype_Level_1; + + -- so, in the interest of testing dispatching, we override them all: + -- except Proc_1 and Proc_2 + + procedure Proc_w_Ap_and_Cp( AP : C392010_0.Access_Procedure; + Cp : Tagtype_Level_1 ); + + function A_Default_Value return Tagtype_Level_1; + + procedure Proc_w_Ap_and_Cp_w_Def( + AP : C392010_0.Access_Procedure := C392010_0.Proc_2'Access; + Cp : Tagtype_Level_1 := A_Default_Value ); + + procedure Proc_w_Cp_Ap( Cp_Ap : access Tagtype_Level_1 ); + + function Func_w_Cp_Ap_and_Cr( Cp_Ap : access Tagtype_Level_1 ) + return Tagtype_Level_1; + + -- to test the objective: +-- Check that a subprogram dispatches correctly when it has +-- access parameters that are not controlling. + + procedure Proc_w_Non( Cp_Ap : access Tagtype_Level_1; + NonCp_Ap : access C392010_0.Tagtype_Level_0 + := C392010_0.Level_0_Global_Object'Access ); + + function Func_w_Non( Cp_Ap : access Tagtype_Level_1; + NonCp_Ap : access C392010_0.Tagtype_Level_0 + := C392010_0.Level_0_Global_Object'Access ) + return Access_Tagtype_Level_1; + + Level_1_Global_Object : aliased Tagtype_Level_1 + := ( Int_Item => 0, + Ch_Item => 'c' ); --------------------------- c + +end C392010_1; + +-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- + +with TCTouch; +package body C392010_1 is + + procedure Proc_w_Ap_and_Cp( AP : C392010_0.Access_Procedure; + Cp : Tagtype_Level_1 ) is + begin + TCTouch.Touch('G'); --------------------------------------------------- G + Ap.All( C392010_0.Tagtype_Level_0( Cp ) ); + end Proc_w_Ap_and_Cp; + + procedure Proc_w_Ap_and_Cp_w_Def( + AP : C392010_0.Access_Procedure := C392010_0.Proc_2'Access; + Cp : Tagtype_Level_1 := A_Default_Value ) + is + begin + TCTouch.Touch('H'); --------------------------------------------------- H + Ap.All( C392010_0.Tagtype_Level_0( Cp ) ); + end Proc_w_Ap_and_Cp_w_Def; + + procedure Proc_w_Cp_Ap( Cp_Ap : access Tagtype_Level_1 ) is + begin + TCTouch.Touch('I'); --------------------------------------------------- I + TCTouch.Touch(Cp_Ap.Ch_Item); -- depends on the value passed ---------- ? + end Proc_w_Cp_Ap; + + function A_Default_Value return Tagtype_Level_1 is + begin + return ( Int_Item => 0, Ch_Item => 'y' ); ---------------------------- y + end A_Default_Value; + + function Func_w_Cp_Ap_and_Cr( Cp_Ap : access Tagtype_Level_1 ) + return Tagtype_Level_1 is + begin + TCTouch.Touch('J'); --------------------------------------------------- J + TCTouch.Touch(Cp_Ap.Ch_Item); -- depends on the value passed ---------- ? + return ( Int_Item => 2, Ch_Item => 'd' ); ----------------------------- d + end Func_w_Cp_Ap_and_Cr; + + procedure Proc_w_Non( Cp_Ap : access Tagtype_Level_1; + NonCp_Ap : access C392010_0.Tagtype_Level_0 + := C392010_0.Level_0_Global_Object'Access ) is + begin + TCTouch.Touch('K'); --------------------------------------------------- K + TCTouch.Touch(Cp_Ap.Ch_Item); ----- depends on the value passed ------- ? + TCTouch.Touch(NonCp_Ap.Ch_Item); -- depends on the value passed ------- ? + end Proc_w_Non; + + Own_Item : aliased Tagtype_Level_1 := ( Int_Item => 3, Ch_Item => 'e' ); + + function Func_w_Non( Cp_Ap : access Tagtype_Level_1; + NonCp_Ap : access C392010_0.Tagtype_Level_0 + := C392010_0.Level_0_Global_Object'Access ) + return Access_Tagtype_Level_1 is + begin + TCTouch.Touch('L'); --------------------------------------------------- L + TCTouch.Touch(Cp_Ap.Ch_Item); ----- depends on the value passed ------- ? + TCTouch.Touch(NonCp_Ap.Ch_Item); -- depends on the value passed ------- ? + return Own_Item'Access; ----------------------------------------------- e + end Func_w_Non; + +end C392010_1; + + + +----------------------------------------------------------------- C392010_2 + +with C392010_0; +with C392010_1; +package C392010_2 is + + Lev2_Level_0_Global_Object : aliased C392010_0.Tagtype_Level_0 + := ( Ch_Item => 'f' ); ---------------------------- f + + type Tagtype_Level_2 is new C392010_1.Tagtype_Level_1 with record + Another_Int_Item : Integer; + end record; + + type Access_Tagtype_Level_2 is access all Tagtype_Level_2; + + -- the following procedures are inherited by the above declaration: + --I procedure Proc_1( P: Tagtype_Level_2 ); + --I + --I procedure Proc_2( P: Tagtype_Level_2 ); + --I + --I procedure Proc_w_Ap_and_Cp( AP : C392010_0.Access_Procedure; + --I Cp : Tagtype_Level_2 ); + --I + --I procedure Proc_w_Ap_and_Cp_w_Def + --I (AP: C392010_0.Access_Procedure := C392010_0. Proc_2'Access; + --I CP: Tagtype_Level_2 := A_Default_Value ); + --I + --I procedure Proc_w_Cp_Ap( Cp_Ap : access Tagtype_Level_2 ); + --I + --I procedure Proc_w_Non( Cp_Ap : access Tagtype_Level_2; + --I NonCp_Ap : access C392010_0.Tagtype_Level_0 + --I := C392010_0.Level_0_Global_Object'Access ); + + -- the following functions become abstract due to the above declaration: + --A function Func_w_Cp_Ap_and_Cr( Cp_Ap : access Tagtype_Level_2 ) + --A return Tagtype_Level_2; + --A + --A function A_Default_Value + --A return Access_Tagtype_Level_2; + + -- so we override the interesting ones to check the objective: +-- Check that a subprogram with parameters of distinct tagged types may +-- be primitive for only one type (i.e. the other tagged types must be +-- declared in other packages). Check that the subprogram does not +-- dispatch for the other type(s). + + procedure Proc_w_Non( Cp_Ap : access Tagtype_Level_2; + NonCp_Ap : access C392010_0.Tagtype_Level_0 + := Lev2_Level_0_Global_Object'Access ); + + function Func_w_Non( Cp_Ap : access Tagtype_Level_2; + NonCp_Ap : access C392010_0.Tagtype_Level_0 + := Lev2_Level_0_Global_Object'Access ) + return C392010_1.Access_Tagtype_Level_1; + + -- and override the other abstract functions + function Func_w_Cp_Ap_and_Cr( Cp_Ap : access Tagtype_Level_2 ) + return Tagtype_Level_2; + + function A_Default_Value return Tagtype_Level_2; + +end C392010_2; + +-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- + +with TCTouch; +with Report; +package body C392010_2 is + + procedure Proc_w_Non( Cp_Ap : access Tagtype_Level_2; + NonCp_Ap : access C392010_0.Tagtype_Level_0 + := Lev2_Level_0_Global_Object'Access ) is + begin + TCTouch.Touch('M'); --------------------------------------------------- M + TCTouch.Touch(Cp_Ap.Ch_Item); ----- depends on the value passed ------- ? + TCTouch.Touch(NonCp_Ap.Ch_Item); -- depends on the value passed ------- ? + end Proc_w_Non; + + function A_Default_Value return Tagtype_Level_2 is + begin + return ( Another_Int_Item | Int_Item => 0, Ch_Item => 'x' ); -------- x + end A_Default_Value; + + Own : aliased Tagtype_Level_2 + := ( Another_Int_Item | Int_Item => 4, Ch_Item => 'g' ); + + function Func_w_Non( Cp_Ap : access Tagtype_Level_2; + NonCp_Ap : access C392010_0.Tagtype_Level_0 + := Lev2_Level_0_Global_Object'Access ) + return C392010_1.Access_Tagtype_Level_1 is + begin + TCTouch.Touch('N'); --------------------------------------------------- N + TCTouch.Touch(Cp_Ap.Ch_Item); ----- depends on the value passed ------- ? + TCTouch.Touch(NonCp_Ap.Ch_Item); -- depends on the value passed ------- ? + return Own'Access; ---------------------------------------------------- g + end Func_w_Non; + + function Func_w_Cp_Ap_and_Cr( Cp_Ap : access Tagtype_Level_2 ) + return Tagtype_Level_2 is + begin + TCTouch.Touch('P'); --------------------------------------------------- P + TCTouch.Touch(Cp_Ap.Ch_Item); ----- depends on the value passed ------- ? + return ( Another_Int_Item | Int_Item => 5, Ch_Item => 'h' ); ---------- h + end Func_w_Cp_Ap_and_Cr; + +end C392010_2; + + + +------------------------------------------------------------------- C392010 + +with Report; +with TCTouch; +with C392010_0, C392010_1, C392010_2; + +procedure C392010 is + + type Access_Class_0 is access all C392010_0.Tagtype_Level_0'Class; + + -- define an array of class-wide pointers: + type Zero_Dispatch_List is array(Natural range <>) of Access_Class_0; + + Item_0 : aliased C392010_0.Tagtype_Level_0 := ( Ch_Item => 'k' ); ------ k + Item_1 : aliased C392010_1.Tagtype_Level_1 := ( Ch_Item => 'm', ------ m + Int_Item => 1 ); + Item_2 : aliased C392010_2.Tagtype_Level_2 := ( Ch_Item => 'n', ------ n + Int_Item => 1, + Another_Int_Item => 1 ); + + Z: Zero_Dispatch_List(1..3) := (Item_0'Access,Item_1'Access,Item_2'Access); + + procedure Subtest_1( Items: Zero_Dispatch_List ) is + -- there is little difference between the actions for _1 and _2 in + -- this subtest due to the nature of _2 inheriting most operations + -- + -- this subtest checks operations available to Level_0'Class + begin + for I in Items'Range loop + + C392010_0.Proc_w_Ap_and_Cp( C392010_0.Proc_1'Access, Items(I).all ); + -- CAk, GAm, GAn + -- actual is class-wide, operation should dispatch + + case I is -- use defaults + when 1 => C392010_0.Proc_w_Ap_and_Cp_w_Def; + -- DBz + when 2 => C392010_1.Proc_w_Ap_and_Cp_w_Def; + -- HBy + when 3 => null; -- Removed following pending resolution by ARG + -- (see AI-00239): + -- C392010_2.Proc_w_Ap_and_Cp_w_Def; + -- HBx + when others => Report.Failed("Unexpected loop value"); + end case; + + C392010_0.Proc_w_Ap_and_Cp_w_Def -- override defaults + ( C392010_0.Proc_1'Access, Items(I).all ); + -- DAk, HAm, HAn + + C392010_0.Proc_w_Cp_Ap( Items(I) ); + -- Ek, Im, In + + -- function return value is controlling for procedure call + C392010_0.Proc_w_Ap_and_Cp_w_Def( C392010_0.Proc_1'Access, + C392010_0.Func_w_Cp_Ap_and_Cr( Items(I) ) ); + -- FkDAb, JmHAd, PnHAh + -- note that the function evaluates first + + end loop; + end Subtest_1; + +-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- + + type Access_Class_1 is access all C392010_1.Tagtype_Level_1'Class; + + type One_Dispatch_List is array(Natural range <>) of Access_Class_1; + + Object_1 : aliased C392010_1.Tagtype_Level_1 := ( Ch_Item => 'p', ----- p + Int_Item => 1 ); + Object_2 : aliased C392010_2.Tagtype_Level_2 := ( Ch_Item => 'q', ----- q + Int_Item => 1, + Another_Int_Item => 1 ); + + D: One_Dispatch_List(1..2) := (Object_1'Access, Object_2'Access); + + procedure Subtest_2( Items: One_Dispatch_List ) is + -- this subtest checks operations available to Level_1'Class, + -- specifically those operations that are not testable in subtest_1, + -- the operations with parameters of the two tagged type objects. + begin + for I in Items'Range loop + + C392010_1.Proc_w_Non( -- t_1, t_2 + C392010_1.Func_w_Non( Items(I), + C392010_0.Tagtype_Level_0(Z(I).all)'Access ), -- Lpk Nqm + C392010_0.Tagtype_Level_0(Z(I+1).all)'Access ); -- Kem Mgn + + end loop; + end Subtest_2; + +begin -- Main test procedure. + + Report.Test ("C392010", "Check that a subprogram dispatches correctly " & + "with a controlling access parameter. " & + "Check that a subprogram dispatches correctly " & + "when it has access parameters that are not " & + "controlling. Check with and without default " & + "expressions" ); + + Subtest_1( Z ); + + -- Original result: + --TCTouch.Validate( "CAkDBzDAkEkFkDAb" + -- & "GAmHByHAmImJmHAd" + -- & "GAnHBxHAnInPnHAh", "Subtest 1" ); + + -- Result pending resultion of AI-239: + TCTouch.Validate( "CAkDBzDAkEkFkDAb" + & "GAmHByHAmImJmHAd" + & "GAnHAnInPnHAh", "Subtest 1" ); + + Subtest_2( D ); + + TCTouch.Validate( "LpkKem" & "NqmMgn", "Subtest 2" ); + + Report.Result; + +end C392010; diff --git a/gcc-4.9/gcc/testsuite/ada/acats/tests/c3/c392011.a b/gcc-4.9/gcc/testsuite/ada/acats/tests/c3/c392011.a new file mode 100644 index 000000000..c32ec77c0 --- /dev/null +++ b/gcc-4.9/gcc/testsuite/ada/acats/tests/c3/c392011.a @@ -0,0 +1,299 @@ +-- C392011.A +-- +-- Grant of Unlimited Rights +-- +-- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687, +-- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained +-- unlimited rights in the software and documentation contained herein. +-- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making +-- this public release, the Government intends to confer upon all +-- recipients unlimited rights equal to those held by the Government. +-- These rights include rights to use, duplicate, release or disclose the +-- released technical data and computer software in whole or in part, in +-- any manner and for any purpose whatsoever, and to have or permit others +-- to do so. +-- +-- DISCLAIMER +-- +-- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR +-- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED +-- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE +-- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE +-- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A +-- PARTICULAR PURPOSE OF SAID MATERIAL. +--* +-- +-- OBJECTIVE: +-- Check that if a function call with a controlling result is itself +-- a controlling operand of an enclosing call on a dispatching operation, +-- then its controlling tag value is determined by the controlling tag +-- value of the enclosing call. +-- +-- TEST DESCRIPTION: +-- The test builds and traverses a "ragged" list; a linked list which +-- contains data elements of three different types (all rooted at +-- Level_0'Class). The traversal of this list checks the objective +-- by calling the dispatching operation "Check" using an item from the +-- list, and calling the function create; thus causing the controlling +-- result of the function to be determined by evaluating the value of +-- the other controlling parameter to the two-parameter Check. +-- +-- +-- CHANGE HISTORY: +-- 22 SEP 95 SAIC Initial version +-- 23 APR 96 SAIC Corrected commentary, differentiated integer. +-- +--! + +----------------------------------------------------------------- C392011_0 + +package C392011_0 is + + type Level_0 is tagged record + Ch_Item : Character; + end record; + + function Create return Level_0; + -- primitive dispatching function + + procedure Check( Left, Right: in Level_0 ); + -- has controlling parameters + +end C392011_0; + +-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- + +with Report; +with TCTouch; +package body C392011_0 is + + The_Character : Character := 'A'; + + function Create return Level_0 is + Created_Item_0 : constant Level_0 := ( Ch_Item => The_Character ); + begin + The_Character := Character'Succ(The_Character); + TCTouch.Touch('A'); -- --- ---- ----- ---- --- -- --- ---- ----- ---- -- A + return Created_Item_0; + end Create; + + procedure Check( Left, Right: in Level_0 ) is + begin + TCTouch.Touch('B'); -- --- ---- ----- ---- --- -- --- ---- ----- ---- -- B + end Check; + +end C392011_0; + +----------------------------------------------------------------- C392011_1 + +with C392011_0; +package C392011_1 is + + type Level_1 is new C392011_0.Level_0 with record + Int_Item : Integer; + end record; + + -- note that Create becomes abstract upon this derivation hence: + + function Create return Level_1; + + procedure Check( Left, Right: in Level_1 ); + +end C392011_1; + +-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- + +with TCTouch; +package body C392011_1 is + + Integer_1 : Integer := 0; + + function Create return Level_1 is + Created_Item_1 : constant Level_1 + := ( C392011_0.Create with Int_Item => Integer_1 ); + -- note call to ^--------------^ -- A + begin + Integer_1 := Integer'Succ(Integer_1); + TCTouch.Touch('C'); -- --- ---- ----- ---- --- -- --- ---- ----- ---- -- C + return Created_Item_1; + end Create; + + procedure Check( Left, Right: in Level_1 ) is + begin + TCTouch.Touch('D'); -- --- ---- ----- ---- --- -- --- ---- ----- ---- -- D + end Check; + +end C392011_1; + +----------------------------------------------------------------- C392011_2 + +with C392011_1; +package C392011_2 is + + type Level_2 is new C392011_1.Level_1 with record + Another_Int_Item : Integer; + end record; + + -- note that Create becomes abstract upon this derivation hence: + + function Create return Level_2; + + procedure Check( Left, Right: in Level_2 ); + +end C392011_2; + +-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- + +with TCTouch; +package body C392011_2 is + + Integer_2 : Integer := 100; + + function Create return Level_2 is + Created_Item_2 : constant Level_2 + := ( C392011_1.Create with Another_Int_Item => Integer_2 ); + -- note call to ^--------------^ -- AC + begin + Integer_2 := Integer'Succ(Integer_2); + TCTouch.Touch('E'); -- --- ---- ----- ---- --- -- --- ---- ----- ---- -- E + return Created_Item_2; + end Create; + + procedure Check( Left, Right: in Level_2 ) is + begin + TCTouch.Touch('F'); -- --- ---- ----- ---- --- -- --- ---- ----- ---- -- F + end Check; + +end C392011_2; + +------------------------------------------------------- C392011_2.C392011_3 + +with C392011_0; +package C392011_2.C392011_3 is + + type Wide_Reference is access all C392011_0.Level_0'Class; + + type Ragged_Element; + + type List_Pointer is access Ragged_Element; + + type Ragged_Element is record + Data : Wide_Reference; + Next : List_Pointer; + end record; + + procedure Build_List; + + procedure Traverse_List; + +end C392011_2.C392011_3; + +-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- + +package body C392011_2.C392011_3 is + + The_List : List_Pointer; + + procedure Build_List is + begin + + -- build a list that looks like: + -- Level_2, Level_1, Level_2, Level_1, Level_0 + -- + -- the mechanism is to create each object, "pushing" the existing list + -- onto the end: cons( new_item, car, cdr ) + + The_List := + new Ragged_Element'( new C392011_0.Level_0'(C392011_0.Create), null ); + -- Level_0 >> A + + The_List := + new Ragged_Element'( new C392011_1.Level_1'(C392011_1.Create), The_List ); + -- Level_1 -> Level_0 >> AC + + The_List := + new Ragged_Element'( new C392011_2.Level_2'(C392011_2.Create), The_List ); + -- Level_2 -> Level_1 -> Level_0 >> ACE + + The_List := + new Ragged_Element'( new C392011_1.Level_1'(C392011_1.Create), The_List ); + -- Level_1 -> Level_2 -> Level_1 -> Level_0 >> AC + + The_List := + new Ragged_Element'( new C392011_2.Level_2'(C392011_2.Create), The_List ); + -- Level_2 -> Level_1 -> Level_2 -> Level_1 -> Level_0 >> ACE + + end Build_List; + + procedure Traverse_List is + + Next_Item : List_Pointer := The_List; + + -- Check that if a function call with a controlling result is itself + -- a controlling operand of an enclosing call on a dispatching operation, + -- then its controlling tag value is determined by the controlling tag + -- value of the enclosing call. + + -- Level_2 -> Level_1 -> Level_2 -> Level_1 -> Level_0 + + begin + + while Next_Item /= null loop -- here we go! + -- these calls better dispatch according to the value in the particular + -- list item; causing the call to create to dispatch accordingly. + -- why do it twice? To make sure order makes no difference + + C392011_0.Check(Next_Item.Data.all, C392011_0.Create); + -- Create will touch first, then Check touches + + C392011_0.Check(C392011_0.Create, Next_Item.Data.all); + + -- Here's what's s'pos'd to 'appen: + -- Check( Lev_2, Create ) >> ACEF + -- Check( Create, Lev_2 ) >> ACEF + -- Check( Lev_1, Create ) >> ACD + -- Check( Create, Lev_1 ) >> ACD + -- Check( Lev_2, Create ) >> ACEF + -- Check( Create, Lev_2 ) >> ACEF + -- Check( Lev_1, Create ) >> ACD + -- Check( Create, Lev_1 ) >> ACD + -- Check( Lev_0, Create ) >> AB + -- Check( Create, Lev_0 ) >> AB + + Next_Item := Next_Item.Next; + end loop; + end Traverse_List; + +end C392011_2.C392011_3; + +------------------------------------------------------------------- C392011 + +with Report; +with TCTouch; +with C392011_2.C392011_3; + +procedure C392011 is + +begin -- Main test procedure. + + Report.Test ("C392011", "Check that if a function call with a " & + "controlling result is itself a controlling " & + "operand of an enclosing call on a dispatching " & + "operation, then its controlling tag value is " & + "determined by the controlling tag value of " & + "the enclosing call" ); + + C392011_2.C392011_3.Build_List; + TCTouch.Validate( "A" & "AC" & "ACE" & "AC" & "ACE", "Build List" ); + + C392011_2.C392011_3.Traverse_List; + TCTouch.Validate( "ACEFACEF" & + "ACDACD" & + "ACEFACEF" & + "ACDACD" & + "ABAB", + "Traverse List" ); + + Report.Result; + +end C392011; diff --git a/gcc-4.9/gcc/testsuite/ada/acats/tests/c3/c392013.a b/gcc-4.9/gcc/testsuite/ada/acats/tests/c3/c392013.a new file mode 100644 index 000000000..3873d9e62 --- /dev/null +++ b/gcc-4.9/gcc/testsuite/ada/acats/tests/c3/c392013.a @@ -0,0 +1,179 @@ +-- C392013.A +-- +-- Grant of Unlimited Rights +-- +-- The Ada Conformity Assessment Authority (ACAA) holds unlimited +-- rights in the software and documentation contained herein. Unlimited +-- rights are the same as those granted by the U.S. Government for older +-- parts of the Ada Conformity Assessment Test Suite, and are defined +-- in DFAR 252.227-7013(a)(19). By making this public release, the ACAA +-- intends to confer upon all recipients unlimited rights equal to those +-- held by the ACAA. These rights include rights to use, duplicate, +-- release or disclose the released technical data and computer software +-- in whole or in part, in any manner and for any purpose whatsoever, and +-- to have or permit others to do so. +-- +-- DISCLAIMER +-- +-- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR +-- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED +-- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE +-- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE +-- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A +-- PARTICULAR PURPOSE OF SAID MATERIAL. +--* +-- +-- OBJECTIVE: +-- Check that the "/=" implicitly declared with the declaration of "=" for +-- a tagged type is legal and can be used in a dispatching call. +-- (Defect Report 8652/0010, as reflected in Technical Corrigendum 1). +-- +-- CHANGE HISTORY: +-- 23 JAN 2001 PHL Initial version. +-- 16 MAR 2001 RLB Readied for release; added identity and negative +-- result cases. +-- 24 MAY 2001 RLB Corrected the result for the 9 vs. 9 case. +--! +with Report; +use Report; +procedure C392013 is + + package P1 is + type T is tagged + record + C1 : Integer; + end record; + function "=" (L, R : T) return Boolean; + end P1; + + package P2 is + type T is new P1.T with private; + function Make (Ancestor : P1.T; X : Float) return T; + private + type T is new P1.T with + record + C2 : Float; + end record; + function "=" (L, R : T) return Boolean; + end P2; + + package P3 is + type T is new P2.T with + record + C3 : Character; + end record; + private + function "=" (L, R : T) return Boolean; + function Make (Ancestor : P1.T; X : Float) return T; + end P3; + + + package body P1 is separate; + package body P2 is separate; + package body P3 is separate; + + + type Cwat is access P1.T'Class; + type Cwat_Array is array (Positive range <>) of Cwat; + + A : constant Cwat_Array := + (1 => new P1.T'(C1 => Ident_Int (3)), + 2 => new P2.T'(P2.Make (Ancestor => (C1 => Ident_Int (5)), X => 4.0)), + 3 => new P2.T'(P2.Make (Ancestor => (C1 => Ident_Int (-5)), X => 4.2)), + 4 => new P1.T'(C1 => Ident_Int (-3)), + 5 => new P2.T'(P2.Make (Ancestor => (C1 => Ident_Int (5)), X => 3.6)), + 6 => new P1.T'(C1 => Ident_Int (4)), + 7 => new P3.T'(P2.Make + (Ancestor => (C1 => Ident_Int (4)), X => 1.2) with + Ident_Char ('a')), + 8 => new P3.T'(P2.Make + (Ancestor => (C1 => Ident_Int (-4)), X => 1.3) with + Ident_Char ('A')), + 9 => new P3.T'(P2.Make + (Ancestor => (C1 => Ident_Int (4)), X => 1.0) with + Ident_Char ('B'))); + + type Truth is ('F', 'T'); + type Truth_Table is array (Positive range <>, Positive range <>) of Truth; + + Equality : constant Truth_Table (A'Range, A'Range) := ("TFFTFFFFF", + "FTTFTFFFF", + "FTTFFFFFF", + "TFFTFFFFF", + "FTFFTFFFF", + "FFFFFTFFF", + "FFFFFFTTF", + "FFFFFFTTF", + "FFFFFFFFT"); + +begin + Test ("C392013", "Check that the ""/="" implicitly declared " & + "with the declaration of ""="" for a tagged " & + "type is legal and can be used in a dispatching call"); + + for I in A'Range loop + for J in A'Range loop + -- Test identity: + if P1."=" (A (I).all, A (J).all) /= + (not P1."/=" (A (I).all, A (J).all)) then + Failed ("Incorrect identity comparing objects" & + Positive'Image (I) & " and" & Positive'Image (J)); + end if; + -- Test the result of "/=": + if Equality (I, J) = 'T' then + if P1."/=" (A (I).all, A (J).all) then + Failed ("Incorrect result comparing objects" & + Positive'Image (I) & " and" & Positive'Image (J) & " - T"); + end if; + else + if not P1."/=" (A (I).all, A (J).all) then + Failed ("Incorrect result comparing objects" & + Positive'Image (I) & " and" & Positive'Image (J) & " - F"); + end if; + end if; + end loop; + end loop; + + Result; +end C392013; +separate (C392013) +package body P1 is + + function "=" (L, R : T) return Boolean is + begin + return abs L.C1 = abs R.C1; + end "="; + +end P1; +separate (C392013) +package body P2 is + + function "=" (L, R : T) return Boolean is + begin + return P1."=" (P1.T (L), P1.T (R)) and then abs (L.C2 - R.C2) <= 0.5; + end "="; + + + function Make (Ancestor : P1.T; X : Float) return T is + begin + return (Ancestor with X); + end Make; + +end P2; +with Ada.Characters.Handling; +separate (C392013) +package body P3 is + + function "=" (L, R : T) return Boolean is + begin + return P2."=" (P2.T (L), P2.T (R)) and then + Ada.Characters.Handling.To_Upper (L.C3) = + Ada.Characters.Handling.To_Upper (R.C3); + end "="; + + function Make (Ancestor : P1.T; X : Float) return T is + begin + return (P2.Make (Ancestor, X) with ' '); + end Make; + +end P3; diff --git a/gcc-4.9/gcc/testsuite/ada/acats/tests/c3/c392014.a b/gcc-4.9/gcc/testsuite/ada/acats/tests/c3/c392014.a new file mode 100644 index 000000000..8ecb4144b --- /dev/null +++ b/gcc-4.9/gcc/testsuite/ada/acats/tests/c3/c392014.a @@ -0,0 +1,227 @@ +-- C392014.A +-- +-- Grant of Unlimited Rights +-- +-- The Ada Conformity Assessment Authority (ACAA) holds unlimited +-- rights in the software and documentation contained herein. Unlimited +-- rights are the same as those granted by the U.S. Government for older +-- parts of the Ada Conformity Assessment Test Suite, and are defined +-- in DFAR 252.227-7013(a)(19). By making this public release, the ACAA +-- intends to confer upon all recipients unlimited rights equal to those +-- held by the ACAA. These rights include rights to use, duplicate, +-- release or disclose the released technical data and computer software +-- in whole or in part, in any manner and for any purpose whatsoever, and +-- to have or permit others to do so. +-- +-- DISCLAIMER +-- +-- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR +-- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED +-- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE +-- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE +-- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A +-- PARTICULAR PURPOSE OF SAID MATERIAL. +--* +-- +-- OBJECTIVE: +-- Check that objects designated by X'Access (where X is of a class-wide +-- type) and new T'Class'(...) are dynamically tagged and can be used in +-- dispatching calls. (Defect Report 8652/0010). +-- +-- CHANGE HISTORY: +-- 18 JAN 2001 PHL Initial version +-- 15 MAR 2001 RLB Readied for release. +-- 03 JUN 2004 RLB Removed constraint for S0, as the subtype has +-- unknown discriminants. + +--! +package C392014_0 is + + type T (D : Integer) is abstract tagged private; + + procedure P (X : access T) is abstract; + function Create (X : Integer) return T'Class; + + Result : Natural := 0; + +private + type T (D : Integer) is abstract tagged null record; +end C392014_0; + +with C392014_0; +package C392014_1 is + type T is new C392014_0.T with private; + function Create (X : Integer) return T'Class; +private + type T is new C392014_0.T with + record + C1 : Integer; + end record; + procedure P (X : access T); +end C392014_1; + +package C392014_1.Child is + type T is new C392014_1.T with private; + procedure P (X : access T); + function Create (X : Integer) return T'Class; +private + type T is new C392014_1.T with + record + C1C : Integer; + end record; +end C392014_1.Child; + +with Report; +use Report; +with C392014_1.Child; +package body C392014_1 is + + procedure P (X : access T) is + begin + C392014_0.Result := C392014_0.Result + X.D + X.C1; + end P; + + function Create (X : Integer) return T'Class is + begin + case X mod Ident_Int (2) is + when 0 => + return C392014_1.Child.Create (X / Ident_Int (2)); + when 1 => + declare + Y : T (D => (X / Ident_Int (2)) mod Ident_Int (20)); + begin + Y.C1 := X / Ident_Int (40); + return T'Class (Y); + end; + when others => + null; + end case; + end Create; + +end C392014_1; + +with C392014_0; +with C392014_1; +package C392014_2 is + type T is new C392014_0.T with private; + function Create (X : Integer) return T'Class; +private + type T is new C392014_1.T with + record + C2 : Integer; + end record; + procedure P (X : access T); +end C392014_2; + +with Report; +use Report; +with C392014_1.Child; +with C392014_2; +package body C392014_0 is + + function Create (X : Integer) return T'Class is + begin + case X mod 3 is + when 0 => + return C392014_1.Create (X / Ident_Int (3)); + when 1 => + return C392014_1.Child.Create (X / Ident_Int (3)); + when 2 => + return C392014_2.Create (X / Ident_Int (3)); + when others => + null; + end case; + end Create; + +end C392014_0; + +with Report; +use Report; +with C392014_0; +package body C392014_1.Child is + + procedure P (X : access T) is + begin + C392014_0.Result := C392014_0.Result + X.D + X.C1 + X.C1C; + end P; + + function Create (X : Integer) return T'Class is + Y : T (D => X mod Ident_Int (20)); + begin + Y.C1 := (X / Ident_Int (20)) mod Ident_Int (20); + Y.C1C := X / Ident_Int (400); + return T'Class (Y); + end Create; + +end C392014_1.Child; + +with Report; +use Report; +package body C392014_2 is + + procedure P (X : access T) is + begin + C392014_0.Result := C392014_0.Result + X.D + X.C2; + end P; + + function Create (X : Integer) return T'Class is + Y : T (D => X mod Ident_Int (20)); + begin + Y.C2 := X / Ident_Int (600); + return T'Class (Y); + end Create; + +end C392014_2; + +with Report; +use Report; +with C392014_0; +with C392014_1.Child; +with C392014_2; +procedure C392014 is + + subtype S0 is C392014_0.T'Class; + subtype S1 is C392014_1.T'Class; + + X0 : aliased C392014_0.T'Class := C392014_0.Create (Ident_Int (5218)); + X1 : aliased C392014_1.T'Class := C392014_1.Create (Ident_Int (8253)); + + Y0 : aliased S0 := C392014_0.Create (Ident_Int (2693)); + Y1 : aliased S1 := C392014_1.Create (Ident_Int (5622)); + + procedure TC_Check (Subtest : String; Expected : Integer) is + begin + if C392014_0.Result = Expected then + Comment ("Subtest " & Subtest & " Passed"); + else + Failed ("Subtest " & Subtest & " Failed"); + end if; + C392014_0.Result := Ident_Int (0); + end TC_Check; + +begin + Test ("C392014", + "Check that objects designated by X'Access " & + "(where X is of a class-wide type) and New T'Class'(...) " & + "are dynamically tagged and can be used in dispatching " & + "calls"); + + C392014_0.P (X0'Access); + TC_Check ("X0'Access", Ident_Int (29)); + C392014_0.P (new C392014_0.T'Class'(C392014_0.Create (Ident_Int (12850)))); + TC_Check ("New C392014_0.T'Class", Ident_Int (27)); + C392014_1.P (X1'Access); + TC_Check ("X1'Access", Ident_Int (212)); + C392014_1.P (new C392014_1.T'Class'(C392014_1.Create (Ident_Int (2031)))); + TC_Check ("New C392014_1.T'Class", Ident_Int (65)); + C392014_0.P (Y0'Access); + TC_Check ("Y0'Access", Ident_Int (18)); + C392014_0.P (new S0'(C392014_0.Create (Ident_Int (6893)))); + TC_Check ("New S0", Ident_Int (20)); + C392014_1.P (Y1'Access); + TC_Check ("Y1'Access", Ident_Int (18)); + C392014_1.P (new S1'(C392014_1.Create (Ident_Int (1861)))); + TC_Check ("New S1", Ident_Int (56)); + + Result; +end C392014; diff --git a/gcc-4.9/gcc/testsuite/ada/acats/tests/c3/c392a01.a b/gcc-4.9/gcc/testsuite/ada/acats/tests/c3/c392a01.a new file mode 100644 index 000000000..8ad789142 --- /dev/null +++ b/gcc-4.9/gcc/testsuite/ada/acats/tests/c3/c392a01.a @@ -0,0 +1,265 @@ +-- C392A01.A + -- +-- Grant of Unlimited Rights +-- +-- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687, +-- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained +-- unlimited rights in the software and documentation contained herein. +-- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making +-- this public release, the Government intends to confer upon all +-- recipients unlimited rights equal to those held by the Government. +-- These rights include rights to use, duplicate, release or disclose the +-- released technical data and computer software in whole or in part, in +-- any manner and for any purpose whatsoever, and to have or permit others +-- to do so. +-- +-- DISCLAIMER +-- +-- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR +-- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED +-- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE +-- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE +-- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A +-- PARTICULAR PURPOSE OF SAID MATERIAL. +--* + -- + -- OBJECTIVE: + -- Check that the use of a class-wide formal parameter allows for the + -- proper dispatching of objects to the appropriate implementation of + -- a primitive operation. Check this for the root tagged type defined + -- in a package, and the extended type is defined in that same package. + -- + -- TEST DESCRIPTION: + -- Declare a root tagged type, and some associated primitive operations. + -- Extend the root type, and override one or more primitive operations, + -- inheriting the other primitive operations from the root type. + -- Derive from the extended type, again overriding some primitive + -- operations and inheriting others (including some that the parent + -- inherited). + -- Define a subprogram with a class-wide parameter, inside of which is a + -- call on a dispatching primitive operation. These primitive operations + -- modify global variables (the class-wide parameter has mode IN). + -- + -- + -- + -- The following hierarchy of tagged types and primitive operations is + -- utilized in this test: + -- + -- type Bank_Account (root) + -- | + -- | Operations + -- | Increment_Bank_Reserve + -- | Assign_Representative + -- | Increment_Counters + -- | Open + -- | + -- type Savings_Account (extended from Bank_Account) + -- | + -- | Operations + -- | (Increment_Bank_Reserve) (inherited) + -- | Assign_Representative (overridden) + -- | Increment_Counters (overridden) + -- | Open (overridden) + -- | + -- type Preferred_Account (extended from Savings_Account) + -- | + -- | Operations + -- | (Increment_Bank_Reserve) (inherited twice - Bank_Acct.) + -- | (Assign_Representative) (inherited - Savings_Acct.) + -- | Increment_Counters (overridden) + -- | Open (overridden) + -- + -- + -- In this test, we are concerned with the following selection of dispatching + -- calls, accomplished with the use of a Bank_Account'Class IN procedure + -- parameter : + -- + -- \ Type + -- Prim. Op \ Bank_Account Savings_Account Preferred_Account + -- \------------------------------------------------ + -- Increment_Bank_Reserve| X X X + -- Assign_Representative | X + -- Increment_Counters | X X X + -- + -- + -- + -- The location of the declaration and derivation of the root and extended + -- types will be varied over a series of tests. Locations of declaration + -- and derivation for a particular test are marked with an asterisk (*). + -- + -- Root type: + -- + -- * Declared in package. + -- Declared in generic package. + -- + -- Extended types: + -- + -- * Derived in parent location. + -- Derived in a nested package. + -- Derived in a nested subprogram. + -- Derived in a nested generic package. + -- Derived in a separate package. + -- Derived in a separate visible child package. + -- Derived in a separate private child package. + -- + -- Primitive Operations: + -- + -- * Procedures with same parameter profile. + -- Procedures with different parameter profile. + -- Functions with same parameter profile. + -- Functions with different parameter profile. + -- Mixture of Procedures and Functions. + -- + -- + -- TEST FILES: + -- This test depends on the following foundation code: + -- + -- F392A00.A + -- + -- The following files comprise this test: + -- + -- => C392A01.A + -- + -- +-- CHANGE HISTORY: +-- 06 Dec 94 SAIC ACVC 2.0 +-- + --! + + with F392A00; -- package Accounts + with Report; + + procedure C392A01 is + + package Accounts renames F392A00; + + -- Declare account objects. + + B_Account : Accounts.Bank_Account; + S_Account : Accounts.Savings_Account; + P_Account : Accounts.Preferred_Account; + + -- Procedures to operate on accounts. + -- Each uses a class-wide IN parameter, as well as a call to a + -- dispatching operation. + + -- Procedure Tabulate_Account performs a dispatching call on a primitive + -- operation that has been overridden for each of the extended types. + + procedure Tabulate_Account (Acct : in Accounts.Bank_Account'Class) is + begin + Accounts.Increment_Counters (Acct); -- Dispatch according to tag. + end Tabulate_Account; + + + -- Procedure Accumulate_Reserve performs a dispatching call on a + -- primitive operation that has been defined for the root type and + -- inherited by each derived type. + + procedure Accumulate_Reserve (Acct : in Accounts.Bank_Account'Class) is + begin + Accounts.Increment_Bank_Reserve (Acct); -- Dispatch according to tag. + end Accumulate_Reserve; + + + -- Procedure Resolve_Dispute performs a dispatching call on a primitive + -- operation that has been defined in the root type, overridden in the + -- first derived extended type, and inherited by the subsequent extended + -- type. + + procedure Resolve_Dispute (Acct : in Accounts.Bank_Account'Class) is + begin + Accounts.Assign_Representative (Acct); -- Dispatch according to tag. + end Resolve_Dispute; + + + + begin -- Main test procedure. + + Report.Test ("C392A01", "Check that the use of a class-wide parameter " & + "allows for proper dispatching where root type " & + "and extended types are declared in the same " & + "package" ); + + Bank_Account_Subtest: + declare + use Accounts; + begin + Accounts.Open (B_Account); + + -- Demonstrate class-wide parameter allowing dispatch by a primitive + -- operation that has been defined for this specific type. + Accumulate_Reserve (Acct => B_Account); + Tabulate_Account (B_Account); + + if (Accounts.Bank_Reserve /= Accounts.Opening_Balance) or + (Accounts.Number_Of_Accounts (Bank) /= 1) or + (Accounts.Number_Of_Accounts (Total) /= 1) + then + Report.Failed ("Failed in Bank_Account_Subtest"); + end if; + + end Bank_Account_Subtest; + + + Savings_Account_Subtest: + declare + use Accounts; + begin + Accounts.Open (Acct => S_Account); + + -- Demonstrate class-wide parameter allowing dispatch by a primitive + -- operation that has been inherited by this extended type. + Accumulate_Reserve (Acct => S_Account); + + -- Demonstrate class-wide parameter allowing dispatch by a primitive + -- operation that has been overridden for this extended type. + Resolve_Dispute (Acct => S_Account); + Tabulate_Account (S_Account); + + if Accounts.Bank_Reserve /= (3.0 * Accounts.Opening_Balance) or + Accounts.Daily_Representative /= Accounts.Manager or + Accounts.Number_Of_Accounts (Savings) /= 1 or + Accounts.Number_Of_Accounts (Total) /= 2 + then + Report.Failed ("Failed in Savings_Account_Subtest"); + end if; + + end Savings_Account_Subtest; + + + Preferred_Account_Subtest: + declare + use Accounts; + begin + Accounts.Open (P_Account); + + -- Verify that the correct implementation of Open (overridden) was + -- used for the Preferred_Account object. + if not Accounts.Verify_Open (P_Account) then + Report.Failed ("Incorrect values for init. Preferred Acct object"); + end if; + + -- Demonstrate class-wide parameter allowing dispatch by a primitive + -- operation that has been twice inherited by this extended type. + Accumulate_Reserve (Acct => P_Account); + + -- Demonstrate class-wide parameter allowing dispatch by a primitive + -- operation that has been overridden for this extended type (the + -- operation was overridden by its parent type as well). + Tabulate_Account (P_Account); + + if Accounts.Bank_Reserve /= 1300.00 or + Accounts.Number_Of_Accounts (Preferred) /= 1 or + Accounts.Number_Of_Accounts (Total) /= 3 + then + Report.Failed ("Failed in Preferred_Account_Subtest"); + end if; + + end Preferred_Account_Subtest; + + + Report.Result; + + end C392A01; + diff --git a/gcc-4.9/gcc/testsuite/ada/acats/tests/c3/c392c05.a b/gcc-4.9/gcc/testsuite/ada/acats/tests/c3/c392c05.a new file mode 100644 index 000000000..6bd3cece7 --- /dev/null +++ b/gcc-4.9/gcc/testsuite/ada/acats/tests/c3/c392c05.a @@ -0,0 +1,164 @@ +-- C392C05.A +-- +-- Grant of Unlimited Rights +-- +-- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687, +-- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained +-- unlimited rights in the software and documentation contained herein. +-- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making +-- this public release, the Government intends to confer upon all +-- recipients unlimited rights equal to those held by the Government. +-- These rights include rights to use, duplicate, release or disclose the +-- released technical data and computer software in whole or in part, in +-- any manner and for any purpose whatsoever, and to have or permit others +-- to do so. +-- +-- DISCLAIMER +-- +-- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR +-- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED +-- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE +-- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE +-- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A +-- PARTICULAR PURPOSE OF SAID MATERIAL. +--* +-- +-- OBJECTIVE: +-- Check that for a call to a dispatching subprogram the subprogram +-- body which is executed is determined by the controlling tag for +-- the case where the call has statically tagged controlling operands +-- of the type T. Check this for various operands of tagged types: +-- objects (declared or allocated), formal parameters, view conversions, +-- function calls (both primitive and non-primitive). +-- +-- TEST DESCRIPTION: +-- This test uses foundation F392C00 to test the usages of statically +-- tagged objects and values. The calls to Validate indicate the +-- expected sequence of procedure calls since the previous call to +-- Validate. Static tags can be determined at compile time, and +-- hence this is a test of correct overload resolution for tagged types. +-- A clever compiler which unrolls loops and does path analysis on +-- access values will be able to perform the same kind of determination +-- for all of the code in this test. +-- +-- TEST FILES: +-- The following files comprise this test: +-- +-- F392C00.A (foundation code) +-- C392C05.A +-- +-- +-- CHANGE HISTORY: +-- 06 Dec 94 SAIC ACVC 2.0 +-- 19 Dec 94 SAIC Removed RM references from objective text. +-- 24 Oct 95 SAIC Updated for ACVC 2.0.1 +-- 13 Feb 97 PWB.CTA Corrected assumption that "or" operands are +-- evaluated in textual order. +--! + +with Report; +with TCTouch; +with F392C00_1; +procedure C392C05 is -- Hardware_Store + + package Switch renames F392C00_1; + + subtype Switch_Class is Switch.Toggle'Class; + + type Reference is access all Switch_Class; + + A_Switch : aliased Switch.Toggle; + A_Dimmer : aliased Switch.Dimmer; + An_Autodim : aliased Switch.Auto_Dimmer; + + type Light_Bank is array(Positive range <>) of Reference; + + Lamps : Light_Bank(1..3); + +begin -- Main test procedure. + + Report.Test ("C392C05", "Check that a dispatching subprogram call is " + & "determined by the controlling tag for statically " + & "tagged controlling operands" ); + +-- Check use of static tagged declared objects, +-- and static tagged formal parameters +-- Must call correct version of flip based on type of controlling op. + +-- Turn on the lights! + + Switch.Flip( A_Switch ); + TCTouch.Validate( "A", "Declared Toggle" ); + + Switch.Flip( A_Dimmer ); + TCTouch.Validate( "GBA", "Declared Dimmer" ); + + Switch.Flip( An_Autodim ); + TCTouch.Validate( "KGBA", "Declared Auto_Dimmer" ); + + Lamps(1) := new Switch.Toggle; + Lamps(2) := new Switch.Dimmer; + Lamps(3) := new Switch.Auto_Dimmer; + +-- Check use of static tagged allocated objects, +-- and static tagged formal parameters in a loop which may dynamically +-- dispatch. If an optimizer unrolls the loop, it may then be statically +-- determined, and no dispatching will occur. Either interpretation is +-- correct. + for Knob in Lamps'Range loop + Switch.Flip( Lamps(Knob).all ); + end loop; + TCTouch.Validate( "AGBAKGBA", "Allocated Objects" ); + +-- Check use of static tagged declared objects, +-- calling non-primitive functions. + if not Switch.TC_Non_Disp( A_Switch ) then + Report.Failed( "Bad Value 1" ); + end if; + TCTouch.Validate( "X", "Nonprimitive Function" ); + + if not Switch.TC_Non_Disp( A_Dimmer ) then + Report.Failed( "Bad Value 2" ); + end if; + TCTouch.Validate( "Y", "Nonprimitive Function" ); + + if not Switch.TC_Non_Disp( An_Autodim ) then + Report.Failed( "Bad Value 3" ); + end if; + TCTouch.Validate( "Z", "Nonprimitive Function" ); + + A_Switch := Switch.Create; + A_Dimmer := Switch.Create; + An_Autodim := Switch.Create; + TCTouch.Validate( "123", "Primitive Function" ); + +-- View conversions + Switch.Brighten( An_Autodim, 50 ); + + Switch.Flip( Switch.Toggle( A_Switch ) ); + Switch.Flip( Switch.Toggle( A_Dimmer ) ); + Switch.Flip( Switch.Dimmer( An_Autodim ) ); + TCTouch.Validate( "DAAGBA", "View Conversions" ); + +-- statically tagged controlling operands (specific types) provided to +-- class-wide functions + if Switch.On( A_Switch ) + or Switch.On( A_Dimmer ) + or Switch.On( An_Autodim ) then + Report.Failed( "Bad Value 4" ); + end if; + TCTouch.Validate( "BBB", "Class-wide" ); + +-- statically tagged controlling operands qualified expressions provided to +-- primitive functions, also using context to determine call to a +-- class-wide function. + if Switch.Off( Switch.Toggle'( Switch.Create ) ) + or else Switch.Off( Switch.Dimmer'( Switch.Create ) ) + or else Switch.Off( Switch.Auto_Dimmer'( Switch.Create ) ) then + Report.Failed( "Bad Value 5" ); + end if; + TCTouch.Validate( "1C2C3C", "Qualified Expression/Class-Wide" ); + + Report.Result; + +end C392C05; diff --git a/gcc-4.9/gcc/testsuite/ada/acats/tests/c3/c392c07.a b/gcc-4.9/gcc/testsuite/ada/acats/tests/c3/c392c07.a new file mode 100644 index 000000000..f13cc0b01 --- /dev/null +++ b/gcc-4.9/gcc/testsuite/ada/acats/tests/c3/c392c07.a @@ -0,0 +1,190 @@ +-- C392C07.A +-- +-- Grant of Unlimited Rights +-- +-- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687, +-- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained +-- unlimited rights in the software and documentation contained herein. +-- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making +-- this public release, the Government intends to confer upon all +-- recipients unlimited rights equal to those held by the Government. +-- These rights include rights to use, duplicate, release or disclose the +-- released technical data and computer software in whole or in part, in +-- any manner and for any purpose whatsoever, and to have or permit others +-- to do so. +-- +-- DISCLAIMER +-- +-- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR +-- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED +-- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE +-- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE +-- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A +-- PARTICULAR PURPOSE OF SAID MATERIAL. +--* +-- +-- OBJECTIVE: +-- Check that for a call to a dispatching subprogram the subprogram +-- body which is executed is determined by the controlling tag for +-- the case where the call has dynamic tagged controlling operands +-- of the type T. Check for calls to these same subprograms where +-- the operands are of specific statically tagged types: +-- objects (declared or allocated), formal parameters, view +-- conversions, and function calls (both primitive and non-primitive). +-- +-- TEST DESCRIPTION: +-- This test uses foundation F392C00 to test the usages of statically +-- tagged objects and values. This test is derived in part from +-- C392C05. +-- +-- +-- CHANGE HISTORY: +-- 06 Dec 94 SAIC ACVC 2.0 +-- 24 Oct 95 SAIC Updated for ACVC 2.0.1 +-- +--! + +with Report; +with TCTouch; +with F392C00_1; +procedure C392C07 is -- Hardware_Store + package Switch renames F392C00_1; + + subtype Switch_Class is Switch.Toggle'Class; + + type Reference is access all Switch_Class; + + A_Switch : aliased Switch.Toggle; + A_Dimmer : aliased Switch.Dimmer; + An_Autodim : aliased Switch.Auto_Dimmer; + + type Light_Bank is array(Positive range <>) of Reference; + + Lamps : Light_Bank(1..3); + +-- dynamically tagged controlling operands : class wide formal parameters + procedure Clamp( Device : in out Switch_Class; On : Boolean := False ) is + begin + if Switch.On( Device ) /= On then + Switch.Flip( Device ); + end if; + end Clamp; + function Class_Item(Bank_Pos: Positive) return Switch_Class is + begin + return Lamps(Bank_Pos).all; + end Class_Item; + +begin -- Main test procedure. + Report.Test ("C392C07", "Check that a dispatching subprogram call is " + & "determined by the controlling tag for " + & "dynamically tagged controlling operands" ); + + Lamps := ( A_Switch'Access, A_Dimmer'Access, An_Autodim'Access ); + +-- dynamically tagged operands referring to +-- statically tagged declared objects + for Knob in Lamps'Range loop + Clamp( Lamps(Knob).all, On => True ); + end loop; + TCTouch.Validate( "BABGBABKGBA", "Clamping On Lamps" ); + + Lamps(1) := new Switch.Toggle; + Lamps(2) := new Switch.Dimmer; + Lamps(3) := new Switch.Auto_Dimmer; + +-- turn the full bank of switches ON +-- dynamically tagged allocated objects + for Knob in Lamps'Range loop + Clamp( Lamps(Knob).all, On => True ); + end loop; + TCTouch.Validate( "BABGBABKGBA", "Dynamic Allocated"); + +-- Double check execution correctness + if Switch.Off( Lamps(1).all ) + or Switch.Off( Lamps(2).all ) + or Switch.Off( Lamps(3).all ) then + Report.Failed( "Bad Value" ); + end if; + TCTouch.Validate( "CCC", "Class-wide"); + +-- turn the full bank of switches OFF + for Knob in Lamps'Range loop + Switch.Flip( Lamps(Knob).all ); + end loop; + TCTouch.Validate( "AGBAKGBA", "Dynamic Allocated, Primitive Ops"); + +-- check switches for OFF +-- a few function calls as operands + for Knob in Lamps'Range loop + if not Switch.Off( Class_Item(Knob) ) then + Report.Failed("At function tests, Switch not OFF"); + end if; + end loop; + TCTouch.Validate( "CCC", + "Using function returning class-wide type"); + +-- Switches are all OFF now. +-- dynamically tagged view conversion + Clamp( Switch_Class( A_Switch ) ); + Clamp( Switch_Class( A_Dimmer ) ); + Clamp( Switch_Class( An_Autodim ) ); + TCTouch.Validate( "BABGBABKGBA", "View Conversions" ); + +-- dynamically tagged controlling operands : declared class wide objects +-- calling primitive functions + declare + Dine_O_Might : Switch_Class := Switch.TC_CW_TI( 't' ); + begin + Switch.Flip( Dine_O_Might ); + if Switch.On( Dine_O_Might ) then + Report.Failed( "Exploded at Dine_O_Might" ); + end if; + TCTouch.Validate( "WAB", "Dispatching function 1" ); + end; + + declare + Dyne_A_Mite : Switch_Class := Switch.TC_CW_TI( 'd' ); + begin + Switch.Flip( Dyne_A_Mite ); + if Switch.On( Dyne_A_Mite ) then + Report.Failed( "Exploded at Dyne_A_Mite" ); + end if; + TCTouch.Validate( "WGBAB", "Dispatching function 2" ); + end; + + declare + Din_Um_Out : Switch_Class := Switch.TC_CW_TI( 'a' ); + begin + Switch.Flip( Din_Um_Out ); + if Switch.Off( Din_Um_Out ) then + Report.Failed( "Exploded at Din_Um_Out" ); + end if; + TCTouch.Validate( "WKCC", "Dispatching function 3" ); + +-- Non-dispatching function calls. + if not Switch.TC_Non_Disp( Switch.Toggle( Din_Um_Out ) ) then + Report.Failed( "Non primitive, via view conversion" ); + end if; + TCTouch.Validate( "X", "View Conversion 1" ); + + if not Switch.TC_Non_Disp( Switch.Dimmer( Din_Um_Out ) ) then + Report.Failed( "Non primitive, via view conversion" ); + end if; + TCTouch.Validate( "Y", "View Conversion 2" ); + end; + + -- a few more function calls as operands (oops) + if not Switch.On( Switch.Toggle'( Switch.Create ) ) then + Report.Failed("Toggle did not create ""On"""); + end if; + + if Switch.Off( Switch.Dimmer'( Switch.Create ) ) then + Report.Failed("Dimmer created ""Off"""); + end if; + + if Switch.Off( Switch.Auto_Dimmer'( Switch.Create ) ) then + Report.Failed("Auto_Dimmer created ""Off"""); + end if; + + Report.Result; +end C392C07; diff --git a/gcc-4.9/gcc/testsuite/ada/acats/tests/c3/c392d01.a b/gcc-4.9/gcc/testsuite/ada/acats/tests/c3/c392d01.a new file mode 100644 index 000000000..bb6e19202 --- /dev/null +++ b/gcc-4.9/gcc/testsuite/ada/acats/tests/c3/c392d01.a @@ -0,0 +1,324 @@ +-- C392D01.A +-- +-- Grant of Unlimited Rights +-- +-- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687, +-- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained +-- unlimited rights in the software and documentation contained herein. +-- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making +-- this public release, the Government intends to confer upon all +-- recipients unlimited rights equal to those held by the Government. +-- These rights include rights to use, duplicate, release or disclose the +-- released technical data and computer software in whole or in part, in +-- any manner and for any purpose whatsoever, and to have or permit others +-- to do so. +-- +-- DISCLAIMER +-- +-- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR +-- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED +-- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE +-- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE +-- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A +-- PARTICULAR PURPOSE OF SAID MATERIAL. +--* +-- +-- OBJECTIVE: +-- Check that, for an implicitly declared dispatching operation that is +-- overridden, the body executed is the body for the overriding +-- subprogram, even if the overriding occurs in a private part. +-- Check that, for an implicitly declared dispatching operation that is +-- NOT overridden, the body executed is the body of the corresponding +-- subprogram of the parent type. +-- +-- Check for the case where the overriding (and non-overriding) operations +-- are declared for a private extension (and its full type) in a public +-- child unit of the package declaring the ancestor type, and the ancestor +-- type is a tagged private type whose full view is itself a derived type. +-- +-- TEST DESCRIPTION: +-- Consider: +-- +-- package Parent is +-- type Root is tagged ... +-- procedure Vis_Op (P: Root); +-- private +-- procedure Pri_Op (P: Root); -- (A) +-- end Parent; +-- +-- package Intermediate is +-- type Mid is tagged private; +-- private +-- type Mid is new Parent.Root with record ... +-- -- Implicit Vis_Op (P: Mid) declared here. +-- +-- procedure Vis_Op (P: Mid); -- (B) +-- end Intermediate; +-- +-- package Intermediate.Child is +-- type Derived is new Mid with private; +-- +-- procedure Pri_Op (P: Derived); -- (C) +-- ... +-- +-- private +-- type Derived is new Mid with record... +-- -- Implicit Vis_Op (P: Derived) declared here. +-- ... +-- end Intermediate.Child; +-- +-- Type Derived inherits Vis_Op from the parent type Mid. Note, however, +-- that it is implicitly declared in the private part (inherited +-- subprograms for a derived_type_definition -- in this case, the full +-- type -- are implicitly declared at the earliest place within the +-- immediate scope of the type_declaration where the corresponding +-- declaration from the parent is visible). +-- +-- Because Parent.Pri_Op is never visible within the immediate scope +-- of Mid, it is not implicitly declared for Mid. Thus, it is also not +-- implicitly declared for Derived. As a result, the version of Pri_Op +-- declared at (C) above does not override an inherited version of +-- Parent.Pri_Op and is totally unrelated to it. +-- +-- Dispatching calls with tag Mid will execute (A) and (B). Dispatching +-- calls with tag Derived from Parent will execute the bodies of (B) +-- and (A). Dispatching calls with tag Derived from Parent.Child +-- will execute the bodies of (B) and (C). +-- +-- TEST FILES: +-- The following files comprise this test: +-- +-- F392D00.A +-- C392D01.A +-- +-- +-- CHANGE HISTORY: +-- 06 Dec 94 SAIC ACVC 2.0 +-- +--! + +with F392D00; +package C392D01_0 is + + type Zoom_Camera is tagged private; + + procedure Self_Test (C : in out Zoom_Camera'Class); + + -- ...Additional operations. + + + function TC_Correct_Result (C : Zoom_Camera; + D : F392D00.Depth_Of_Field; + S : F392D00.Shutter_Speed) return Boolean; + +private + + type Magnification is (Low, Medium, High); + + type Zoom_Camera is new F392D00.Remote_Camera with record + Mag : Magnification; + end record; + + -- procedure Focus (C : in out Zoom_Camera; -- Implicitly + -- Depth : in Depth_Of_Field) -- declared + -- here. + + procedure Focus (C : in out Zoom_Camera; -- Overrides + Depth : in F392D00.Depth_Of_Field); -- inherited op. + + -- For the remote zoom camera, perhaps the focusing algorithm is different + -- in some way, so the original Focus operation is overridden here. + + -- Since the partial view is not an extension, the overriding operation + -- must be declared after the full type. This version of Focus, although + -- not visible for type Zoom_Camera from outside the package, can still be + -- dispatched to. + + + -- Note: F392D00.Set_Shutter_Speed is inherited by Zoom_Camera from + -- F392D00.Remote_Camera, but since the operation never becomes visible + -- within the immediate scope of Zoom_Camera, it is never implicitly + -- declared. + +end C392D01_0; + + + --==================================================================-- + + +package body C392D01_0 is + + procedure Focus (C : in out Zoom_Camera; + Depth : in F392D00.Depth_Of_Field) is + begin + -- Artificial for testing purposes. + C.DOF := 83; + end Focus; + + ----------------------------------------------------------- + -- Indirect call to F392D00.Self_Test since the main does not know + -- that Zoom_Camera is a private extension of F392D00.Basic_Camera. + procedure Self_Test (C : in out Zoom_Camera'Class) is + begin + F392D00.Self_Test (C); + -- ...Additional self-testing. + end Self_Test; + + ----------------------------------------------------------- + function TC_Correct_Result (C : Zoom_Camera; + D : F392D00.Depth_Of_Field; + S : F392D00.Shutter_Speed) return Boolean is + use type F392D00.Depth_Of_Field; + use type F392D00.Shutter_Speed; + begin + return (C.DOF = D and C.Shutter = S); + end TC_Correct_Result; + +end C392D01_0; + + + --==================================================================-- + + +with F392D00; +package C392D01_0.C392D01_1 is + + type Film_Speed is private; + + type Auto_Speed is new Zoom_Camera with private; + + -- Implicit function TC_Correct_Result (Auto_Speed) declared here. + + procedure Set_Shutter_Speed (C : in out Auto_Speed; + Speed : in F392D00.Shutter_Speed); + + -- This version of Set_Shutter_Speed does NOT override the operation + -- inherited from Zoom_Camera, because the inherited operation is never + -- visible (and thus, is never implicitly declared) within the immediate + -- scope of type Auto_Speed. + + procedure Self_Test (C : in out Auto_Speed'Class); + + -- ...Other operations. + +private + type Film_Speed is (One_Hundred, Two_Hundred, Four_Hundred); + + type Auto_Speed is new Zoom_Camera with record + ASA : Film_Speed; + end record; + + -- procedure Focus (C : in out Auto_Speed; -- Implicitly + -- Depth : in F392D00.Depth_Of_Field); -- declared + -- here. + +end C392D01_0.C392D01_1; + + + --==================================================================-- + + +package body C392D01_0.C392D01_1 is + + procedure Set_Shutter_Speed (C : in out Auto_Speed; + Speed : in F392D00.Shutter_Speed) is + begin + -- Artificial for testing purposes. + C.Shutter := F392D00.Two_Fifty; + end Set_Shutter_Speed; + + ------------------------------------------------------- + procedure Self_Test (C : in out Auto_Speed'Class) is + begin + -- Artificial for testing purposes. + Set_Shutter_Speed (C, F392D00.Thousand); + Focus (C, 27); + end Self_Test; + +end C392D01_0.C392D01_1; + + + --==================================================================-- + + +with F392D00; +with C392D01_0.C392D01_1; + +with Report; + +procedure C392D01 is + Zooming_Camera : C392D01_0.Zoom_Camera; + Auto_Camera1 : C392D01_0.C392D01_1.Auto_Speed; + Auto_Camera2 : C392D01_0.C392D01_1.Auto_Speed; + + TC_Expected_Zoom_Depth : constant F392D00.Depth_Of_Field := 83; + TC_Expected_Auto_Depth : constant F392D00.Depth_Of_Field := 83; + TC_Expected_Depth : constant F392D00.Depth_Of_Field := 83; + TC_Expected_Zoom_Speed : constant F392D00.Shutter_Speed + := F392D00.Thousand; + TC_Expected_Auto_Speed : constant F392D00.Shutter_Speed + := F392D00.Thousand; + TC_Expected_Speed : constant F392D00.Shutter_Speed + := F392D00.Two_Fifty; + + use type F392D00.Depth_Of_Field; + use type F392D00.Shutter_Speed; + +begin + Report.Test ("C392D01", "Dispatching for overridden and non-overridden " & + "primitive subprograms: private extension declared in child " & + "unit, parent is tagged private whose full view is derived " & + "type"); + + + +-- Call the class-wide operation (Self_Test) for Zoom_Camera'Class, which +-- itself calls the class-wide operation for Remote_Camera'Class, which +-- in turn makes dispatching calls to Focus and Set_Shutter_Speed: + + + -- For an object of type Zoom_Camera, the dispatching call to Focus should + -- dispatch to the body explicitly declared for Zoom_Camera. The dispatching + -- to Set_Shutter_Speed should dispatch to the body declared for + -- Remote_Camera: + + C392D01_0.Self_Test(Zooming_Camera); + + if not C392D01_0.TC_Correct_Result (Zooming_Camera, + TC_Expected_Zoom_Depth, + TC_Expected_Zoom_Speed) + then + Report.Failed ("Calls dispatched incorrectly for tagged private type"); + end if; + + -- For an object of type Auto_Speed, the dispatching call to Focus should + -- dispatch to the body explicitly declared for Zoom_Camera. The dispatching + -- call to Set_Shutter_Speed should dispatch to the body explicitly declared + -- for Remote_Camera: + + C392D01_0.Self_Test(Auto_Camera1); + + if not C392D01_0.C392D01_1.TC_Correct_Result (Auto_Camera1, + TC_Expected_Auto_Depth, + TC_Expected_Auto_Speed) + then + Report.Failed ("Calls dispatched incorrectly for private extension"); + end if; + + -- Call to Self_Test from C392D01_0.C392D01_1 invokes the dispatching call + -- to Focus which should dispatch to the body explicitly declared for + -- Zoom_Camera. The dispatching call to Set_Shutter_Speed should dispatch + -- to the body explicitly declared for Auto_Speed: + + C392D01_0.C392D01_1.Self_Test(Auto_Camera2); + + if not C392D01_0.C392D01_1.TC_Correct_Result (Auto_Camera2, + TC_Expected_Depth, + TC_Expected_Speed) + then + Report.Failed ("Call to explicit subprogram executed the wrong body"); + end if; + + Report.Result; + +end C392D01; diff --git a/gcc-4.9/gcc/testsuite/ada/acats/tests/c3/c392d02.a b/gcc-4.9/gcc/testsuite/ada/acats/tests/c3/c392d02.a new file mode 100644 index 000000000..d8e012cbe --- /dev/null +++ b/gcc-4.9/gcc/testsuite/ada/acats/tests/c3/c392d02.a @@ -0,0 +1,185 @@ +-- C392D02.A +-- +-- Grant of Unlimited Rights +-- +-- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687, +-- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained +-- unlimited rights in the software and documentation contained herein. +-- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making +-- this public release, the Government intends to confer upon all +-- recipients unlimited rights equal to those held by the Government. +-- These rights include rights to use, duplicate, release or disclose the +-- released technical data and computer software in whole or in part, in +-- any manner and for any purpose whatsoever, and to have or permit others +-- to do so. +-- +-- DISCLAIMER +-- +-- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR +-- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED +-- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE +-- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE +-- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A +-- PARTICULAR PURPOSE OF SAID MATERIAL. +--* +-- +-- OBJECTIVE: +-- Check that a primitive procedure declared in a private part is not +-- overridden by a procedure explicitly declared at a place where the +-- primitive procedure in question is not visible. +-- +-- Check for the case where the non-overriding operation is declared in a +-- separate (non-child) package from that declaring the parent type, and +-- the descendant type is a record extension. +-- +-- TEST DESCRIPTION: +-- Consider: +-- +-- package P is +-- type Root is tagged ... +-- private +-- procedure Pri_Op (A: Root); +-- end P; +-- +-- with P; +-- package Q is +-- type Derived is new P.Root with record... +-- procedure Pri_Op (A: Derived); -- Does NOT override parent's Op. +-- ... +-- end Q; +-- +-- Type Derived inherits Pri_Op from the parent type Root. However, +-- because P.Pri_Op is never visible within the immediate scope of +-- Derived, it is not implicitly declared for Derived. As a result, +-- the explicit Q.Pri_Op does not override P.Pri_Op and is totally +-- unrelated to it. +-- +-- Dispatching calls to P.Pri_Op with operands of tag Derived will +-- not dispatch to Q.Pri_Op; the body executed will be that of P.Pri_Op. +-- +-- TEST FILES: +-- The following files comprise this test: +-- +-- F392D00.A +-- C392D02.A +-- +-- +-- CHANGE HISTORY: +-- 06 Dec 94 SAIC ACVC 2.0 +-- +--! + +with F392D00; +package C392D02_0 is + + type Aperture is (Eight, Sixteen); + + type Auto_Speed is new F392D00.Remote_Camera with record + -- ... + FStop : Aperture; + end record; + + + procedure Set_Shutter_Speed (C : in out Auto_Speed; + Speed : in F392D00.Shutter_Speed); + -- Does NOT override. + + -- This version of Set_Shutter_Speed does NOT override the operation + -- inherited from the parent, because the inherited operation is never + -- visible (and thus, is never implicitly declared) within the immediate + -- scope of type Auto_Speed. + + procedure Self_Test (C : in out Auto_Speed'Class); + + -- ...Other operations. + +end C392D02_0; + + + --==================================================================-- + + +package body C392D02_0 is + + procedure Set_Shutter_Speed (C : in out Auto_Speed; + Speed : in F392D00.Shutter_Speed) is + begin + -- Artificial for testing purposes. + C.Shutter := F392D00.Four_Hundred; + end Set_Shutter_Speed; + + ---------------------------------------------------- + procedure Self_Test (C : in out Auto_Speed'Class) is + begin + -- Should dispatch to the Set_Shutter_Speed explicitly declared + -- for Auto_Speed. + Set_Shutter_Speed (C, F392D00.Two_Fifty); + end Self_Test; + +end C392D02_0; + + + --==================================================================-- + + +with F392D00; +with C392D02_0; + +with Report; + +procedure C392D02 is + Basic_Camera : F392D00.Remote_Camera; + Auto_Camera1 : C392D02_0.Auto_Speed; + Auto_Camera2 : C392D02_0.Auto_Speed; + + TC_Expected_Basic_Speed : constant F392D00.Shutter_Speed + := F392D00.Thousand; + TC_Expected_Speed : constant F392D00.Shutter_Speed + := F392D00.Four_Hundred; + + use type F392D00.Shutter_Speed; + +begin + Report.Test ("C392D02", "Dispatching for non-overridden primitive " & + "subprograms: record extension declared in non-child " & + "package, parent is tagged record"); + +-- Call the class-wide operation for Remote_Camera'Class, which dispatches +-- to Set_Shutter_Speed: + + -- For an object of type Remote_Camera, the dispatching call should + -- dispatch to the body declared for the root type: + + F392D00.Self_Test(Basic_Camera); + + if Basic_Camera.Shutter /= TC_Expected_Basic_Speed then + Report.Failed ("Call dispatched incorrectly for root type"); + end if; + + + -- C392D02_0.Set_Shutter_Speed should never be called by F392D00.Self_Test, + -- since C392D02_0.Set_Shutter_Speed does not override + -- F392D00.Set_Shutter_Speed. + + -- For an object of type Auto_Speed, the dispatching call should + -- also dispatch to the body declared for the root type: + + F392D00.Self_Test(Auto_Camera1); + + if Auto_Camera1.Shutter /= TC_Expected_Basic_Speed then + Report.Failed ("Call dispatched incorrectly for derived type"); + end if; + + -- Call to Self_Test from C392D02_0 invokes the dispatching call to + -- Set_Shutter_Speed which should dispatch to the body explicitly declared + -- for Auto_Speed: + + C392D02_0.Self_Test(Auto_Camera2); + + if Auto_Camera2.Shutter /= TC_Expected_Speed then + Report.Failed ("Call to explicit subprogram executed the wrong body"); + end if; + + Report.Result; + +end C392D02; diff --git a/gcc-4.9/gcc/testsuite/ada/acats/tests/c3/c392d03.a b/gcc-4.9/gcc/testsuite/ada/acats/tests/c3/c392d03.a new file mode 100644 index 000000000..3a488952e --- /dev/null +++ b/gcc-4.9/gcc/testsuite/ada/acats/tests/c3/c392d03.a @@ -0,0 +1,248 @@ +-- C392D03.A +-- +-- Grant of Unlimited Rights +-- +-- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687, +-- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained +-- unlimited rights in the software and documentation contained herein. +-- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making +-- this public release, the Government intends to confer upon all +-- recipients unlimited rights equal to those held by the Government. +-- These rights include rights to use, duplicate, release or disclose the +-- released technical data and computer software in whole or in part, in +-- any manner and for any purpose whatsoever, and to have or permit others +-- to do so. +-- +-- DISCLAIMER +-- +-- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR +-- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED +-- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE +-- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE +-- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A +-- PARTICULAR PURPOSE OF SAID MATERIAL. +--* +-- +-- OBJECTIVE: +-- Check that, for an inherited dispatching operation that is overridden, +-- the body executed is the body of the overriding subprogram, even if +-- the overriding occurs in a private part. +-- +-- Check for the case where the overriding operation is declared in a +-- separate (non-child) package from that declaring the parent type, and +-- the descendant type is a record extension. +-- +-- Check for both dispatching and nondispatching calls. +-- +-- TEST DESCRIPTION: +-- Consider: +-- +-- package P is +-- type Root is tagged ... +-- procedure Op (A: Root); +-- end P; +-- +-- with P; +-- package Q is +-- type Derived1 is new P.Root with record... +-- -- Implicit procedure Op (A: Derived1) declared here. +-- type Derived2 is new P.Root with private... +-- -- Implicit procedure Op (A: Derived2) declared here. +-- type New_Derived is new Derived1 with private... +-- -- Implicit procedure Op (A: New_Derived) declared here. +-- private +-- procedure Op (A: Derived1); -- Overrides parent's Op. +-- type Derived2 is new P.Root with record... +-- procedure Op (A: Derived2); -- Overrides parent's Op. +-- type New_Derived is new Derived1 with record... +-- ... +-- end Q; +-- +-- Both type Derived1 and Derived2 inherit Op from the parent type Root. +-- Type New_Derived inherits (inherited) Op from Derived1. The inherited +-- operation is implicitly declared immediately after the type extension. +-- The inherited operation is overridden by an explicit declaration in +-- the private part. Even though the overriding operation is private, +-- calls to Op with an operand of tag Derived1, Derived2, or New_Derived +-- will execute the body of the overriding operation. +-- +-- TEST FILES: +-- The following files comprise this test: +-- +-- F392D00.A +-- C392D03.A +-- +-- +-- CHANGE HISTORY: +-- 06 Dec 94 SAIC ACVC 2.0 +-- +--! + +with F392D00; +package C392D03_0 is + + type Aperture is (Eight, Sixteen); + + type Auto_Focus is new F392D00.Remote_Camera with record + -- ... + FStop : Aperture; + end record; + + -- Implicit procedure Focus (C : in out Auto_Focus; + -- Depth : in Depth_Of_Field) declared here. + + type Auto_Flashing is new F392D00.Remote_Camera with private; + + -- Implicit procedure Focus (C : in out Auto_Flashing; + -- Depth : in Depth_Of_Field) declared here. + + type Special_Focus is new Auto_Focus with private; + + -- Implicit procedure Focus (C : in out Special_Focus; + -- Depth : in Depth_Of_Field) declared here. + + -- ...Other operations. + +private + + procedure Focus (C : in out Auto_Focus; -- Overrides + Depth : in F392D00.Depth_Of_Field); -- parent's op. + + -- For the improved remote camera, focus is set automatically, so it is + -- declared as a private operation. + + type Auto_Flashing is new F392D00.Remote_Camera with null record; + + procedure Focus (C : in out Auto_Flashing; -- Overrides + Depth : in F392D00.Depth_Of_Field); -- parent's op. + + type Special_Focus is new Auto_Focus with null record; + +end C392D03_0; + + + --==================================================================-- + + +package body C392D03_0 is + + procedure Focus (C : in out Auto_Focus; + Depth : in F392D00.Depth_Of_Field) is + begin + -- Artificial for testing purposes. + C.DOF := 52; + end Focus; + + ----------------------------------------------------------- + procedure Focus (C : in out Auto_Flashing; + Depth : in F392D00.Depth_Of_Field) is + begin + -- Artificial for testing purposes. + C.DOF := 91; + end Focus; + +end C392D03_0; + + + --==================================================================-- + + +with F392D00; +with C392D03_0; + +with Report; + +procedure C392D03 is + + type Focus_Ptr is access procedure + (P1 : in out C392D03_0.Auto_Focus; + P2 : in F392D00.Depth_Of_Field); + + Basic_Camera : F392D00.Remote_Camera; + Auto_Camera1 : C392D03_0.Auto_Focus; + Auto_Camera2 : C392D03_0.Auto_Focus; + Flash_Camera1 : C392D03_0.Auto_Flashing; + Flash_Camera2 : C392D03_0.Auto_Flashing; + Special_Camera : C392D03_0.Special_Focus; + Auto_Depth : F392D00.Depth_Of_Field := 78; + + TC_Expected_Basic_Depth : constant F392D00.Depth_Of_Field := 46; + TC_Expected_Auto_Depth : constant F392D00.Depth_Of_Field := 52; + TC_Expected_Depth : constant F392D00.Depth_Of_Field := 91; + + FP : Focus_Ptr := C392D03_0.Focus'Access; + + use type F392D00.Depth_Of_Field; + +begin + Report.Test ("C392D03", "Dispatching for overridden primitive " & + "subprograms: record extension declared in non-child " & + "package, parent is tagged record"); + + +-- Call the class-wide operation for Remote_Camera'Class, which itself makes +-- a dispatching call to Focus: + + -- For an object of type Remote_Camera, the dispatching call should + -- dispatch to the body declared for the root type: + + F392D00.Self_Test(Basic_Camera); + + if Basic_Camera.DOF /= TC_Expected_Basic_Depth then + Report.Failed ("Call dispatched incorrectly for root type"); + end if; + + + -- For an object of type Auto_Focus, the dispatching call should + -- dispatch to the body declared for the derived type: + + F392D00.Self_Test(Auto_Camera1); + + if Auto_Camera1.DOF /= TC_Expected_Auto_Depth then + Report.Failed ("Call dispatched incorrectly for Auto_Focus type"); + end if; + + + -- For an object of type Auto_Flash, the dispatching call should + -- also dispatch to the body declared for the derived type: + + F392D00.Self_Test(Flash_Camera1); + + if Flash_Camera1.DOF /= TC_Expected_Depth then + Report.Failed ("Call dispatched incorrectly for Auto_Flash type"); + end if; + + -- For an object of Auto_Flash type, a non-dispatching call to Focus should + -- execute the body declared for the derived type (even through it is + -- declared in the private part). + + C392D03_0.Focus (Flash_Camera2, Auto_Depth); + + if Flash_Camera2.DOF /= TC_Expected_Depth then + Report.Failed ("Non-dispatching call to privately overriding " & + "subprogram executed the wrong body"); + end if; + + -- For an object of Auto_Focus type, a non-dispatching call to Focus should + -- execute the body declared for the derived type (even through it is + -- declared in the private part). + + FP.all (Auto_Camera2, Auto_Depth); + + if Auto_Camera2.DOF /= TC_Expected_Auto_Depth then + Report.Failed ("Non-dispatching call by using access to overriding " & + "subprogram executed the wrong body"); + end if; + + -- For an object of type Special_Camera, the dispatching call should + -- also dispatch to the body declared for the derived type: + + F392D00.Self_Test(Special_Camera); + + if Special_Camera.DOF /= TC_Expected_Auto_Depth then + Report.Failed ("Call dispatched incorrectly for Special_Camera type"); + end if; + + Report.Result; + +end C392D03; diff --git a/gcc-4.9/gcc/testsuite/ada/acats/tests/c3/c393001.a b/gcc-4.9/gcc/testsuite/ada/acats/tests/c3/c393001.a new file mode 100644 index 000000000..9d6f85c63 --- /dev/null +++ b/gcc-4.9/gcc/testsuite/ada/acats/tests/c3/c393001.a @@ -0,0 +1,407 @@ +-- C393001.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 abstract type can be declared, and in turn concrete +-- types can be derived from it. Check that the definition of +-- actual subprograms associated with the derived types dispatch +-- correctly. +-- +-- TEST DESCRIPTION: +-- This test declares an abstract type Breaker in a package, and +-- then derives from it. The type Basic_Breaker defines the least +-- possible in order to not be abstract. The type Ground_Fault is +-- defined to inherit as much as possible, whereas type Special_Breaker +-- overrides everything it can. The type Special_Breaker also includes +-- an embedded Basic_Breaker object. The main program then utilizes +-- each of the three types of breaker, and to ascertain that the +-- overloading and tagging resolution are correct, each "Create" +-- procedure is called with a unique value. The diagram below +-- illustrates the relationships. This test is derived from C3A2001. +-- +-- Abstract type: Breaker +-- | +-- Basic_Breaker (Short) +-- / \ +-- (Sharp) Ground_Fault Special_Breaker (Shock) +-- +-- Test structure is an array of class-wide objects, modeling a circuit +-- as a list of components. The test then creates some values, and +-- traverses the list to determine correct operation. +-- +-- +-- CHANGE HISTORY: +-- 06 Dec 94 SAIC ACVC 2.0 +-- 13 Nov 95 SAIC Revised for 2.0.1 +-- +--! + +----------------------------------------------------------------- C393001_1 + +with Report; +package C393001_1 is + + type Breaker is abstract tagged private; + type Status is ( Power_Off, Power_On, Tripped, Failed ); + + procedure Flip ( The_Breaker : in out Breaker ) is abstract; + procedure Trip ( The_Breaker : in out Breaker ) is abstract; + procedure Reset( The_Breaker : in out Breaker ) is abstract; + procedure Fail ( The_Breaker : in out Breaker ); + + procedure Set ( The_Breaker : in out Breaker'Class; To_State : Status ); + + function Status_Of( The_Breaker : Breaker ) return Status; + +private + type Breaker is abstract tagged record + State : Status := Power_Off; + end record; +end C393001_1; + +with TCTouch; +package body C393001_1 is + procedure Fail( The_Breaker : in out Breaker ) is ------------------- a + begin + TCTouch.Touch( 'a' ); + The_Breaker.State := Failed; + end Fail; + + procedure Set( The_Breaker : in out Breaker'Class; To_State : Status ) is + begin + The_Breaker.State := To_State; + end Set; + + function Status_Of( The_Breaker : Breaker ) return Status is ------- b + begin + TCTouch.Touch( 'b' ); + return The_Breaker.State; + end Status_Of; +end C393001_1; + +----------------------------------------------------------------- C393001_2 + +with C393001_1; +package C393001_2 is + + type Basic_Breaker is new C393001_1.Breaker with private; + + type Voltages is ( V12, V110, V220, V440 ); + type Amps is ( A1, A5, A10, A25, A100 ); + + function Construct( Voltage : Voltages; Amperage : Amps ) + return Basic_Breaker; + + procedure Flip ( The_Breaker : in out Basic_Breaker ); + procedure Trip ( The_Breaker : in out Basic_Breaker ); + procedure Reset( The_Breaker : in out Basic_Breaker ); +private + type Basic_Breaker is new C393001_1.Breaker with record + Voltage_Level : Voltages := V110; + Amperage : Amps; + end record; +end C393001_2; + +with TCTouch; +package body C393001_2 is + function Construct( Voltage : Voltages; Amperage : Amps ) ----------- c + return Basic_Breaker is + It : Basic_Breaker; + begin + TCTouch.Touch( 'c' ); + It.Amperage := Amperage; + It.Voltage_Level := Voltage; + C393001_1.Set( It, C393001_1.Power_Off ); + return It; + end Construct; + + procedure Flip ( The_Breaker : in out Basic_Breaker ) is ------------ d + begin + TCTouch.Touch( 'd' ); + case Status_Of( The_Breaker ) is + when C393001_1.Power_Off => + C393001_1.Set( The_Breaker, C393001_1.Power_On ); + when C393001_1.Power_On => + C393001_1.Set( The_Breaker, C393001_1.Power_Off ); + when C393001_1.Tripped | C393001_1.Failed => null; + end case; + end Flip; + + procedure Trip ( The_Breaker : in out Basic_Breaker ) is ------------ e + begin + TCTouch.Touch( 'e' ); + C393001_1.Set( The_Breaker, C393001_1.Tripped ); + end Trip; + + procedure Reset( The_Breaker : in out Basic_Breaker ) is ------------ f + begin + TCTouch.Touch( 'f' ); + case Status_Of( The_Breaker ) is + when C393001_1.Power_Off | C393001_1.Tripped => + C393001_1.Set( The_Breaker, C393001_1.Power_On ); + when C393001_1.Power_On | C393001_1.Failed => null; + end case; + end Reset; + +end C393001_2; + +with C393001_1,C393001_2; +package C393001_3 is + + type Ground_Fault is new C393001_2.Basic_Breaker with private; + + function Construct( Voltage : C393001_2.Voltages; Amperage : C393001_2.Amps +) + return Ground_Fault; + + procedure Set_Trip( The_Breaker : in out Ground_Fault; + Capacitance : in Integer ); + +private + type Ground_Fault is new C393001_2.Basic_Breaker with record + Capacitance : Integer; + end record; +end C393001_3; + +----------------------------------------------------------------- C393001_3 + +with TCTouch; +package body C393001_3 is + + function Construct( Voltage : C393001_2.Voltages; ------------------ g + Amperage : C393001_2.Amps ) + return Ground_Fault is + + It : Ground_Fault; + + procedure Set_Root( It: in out C393001_2.Basic_Breaker ) is + begin + It := C393001_2.Construct( Voltage, Amperage ); + end Set_Root; + + begin + TCTouch.Touch( 'g' ); + Set_Root( C393001_2.Basic_Breaker( It ) ); + It.Capacitance := 0; + return It; + end Construct; + + procedure Set_Trip( The_Breaker : in out Ground_Fault; -------------- h + Capacitance : in Integer ) is + begin + TCTouch.Touch( 'h' ); + The_Breaker.Capacitance := Capacitance; + end Set_Trip; + +end C393001_3; + +----------------------------------------------------------------- C393001_4 + +with C393001_1, C393001_2; +package C393001_4 is + + type Special_Breaker is new C393001_2.Basic_Breaker with private; + + function Construct( Voltage : C393001_2.Voltages; + Amperage : C393001_2.Amps ) + return Special_Breaker; + + procedure Flip ( The_Breaker : in out Special_Breaker ); + procedure Trip ( The_Breaker : in out Special_Breaker ); + procedure Reset( The_Breaker : in out Special_Breaker ); + procedure Fail ( The_Breaker : in out Special_Breaker ); + + function Status_Of( The_Breaker : Special_Breaker ) return C393001_1.Status; + function On_Backup( The_Breaker : Special_Breaker ) return Boolean; + +private + type Special_Breaker is new C393001_2.Basic_Breaker with record + Backup : C393001_2.Basic_Breaker; + end record; +end C393001_4; + +with TCTouch; +package body C393001_4 is + + function Construct( Voltage : C393001_2.Voltages; --------------- i + Amperage : C393001_2.Amps ) + return Special_Breaker is + It: Special_Breaker; + procedure Set_Root( It: in out C393001_2.Basic_Breaker ) is + begin + It := C393001_2.Construct( Voltage, Amperage ); + end Set_Root; + begin + TCTouch.Touch( 'i' ); + Set_Root( C393001_2.Basic_Breaker( It ) ); + Set_Root( It.Backup ); + return It; + end Construct; + + function Status_Of( It: C393001_1.Breaker ) return C393001_1.Status + renames C393001_1.Status_Of; + + procedure Flip ( The_Breaker : in out Special_Breaker ) is ---------- j + begin + TCTouch.Touch( 'j' ); + case Status_Of( C393001_1.Breaker( The_Breaker )) is + when C393001_1.Power_Off | C393001_1.Power_On => + C393001_2.Flip( C393001_2.Basic_Breaker( The_Breaker ) ); + when others => + C393001_2.Flip( The_Breaker.Backup ); + end case; + end Flip; + + procedure Trip ( The_Breaker : in out Special_Breaker ) is ---------- k + begin + TCTouch.Touch( 'k' ); + case Status_Of( C393001_1.Breaker( The_Breaker )) is + when C393001_1.Power_Off => null; + when C393001_1.Power_On => + C393001_2.Reset( The_Breaker.Backup ); + C393001_2.Trip( C393001_2.Basic_Breaker( The_Breaker ) ); + when others => + C393001_2.Trip( The_Breaker.Backup ); + end case; + end Trip; + + procedure Reset( The_Breaker : in out Special_Breaker ) is ---------- l + begin + TCTouch.Touch( 'l' ); + case Status_Of( C393001_1.Breaker( The_Breaker )) is + when C393001_1.Tripped => + C393001_2.Reset( C393001_2.Basic_Breaker( The_Breaker )); + when C393001_1.Failed => + C393001_2.Reset( The_Breaker.Backup ); + when C393001_1.Power_On | C393001_1.Power_Off => + null; + end case; + end Reset; + + procedure Fail ( The_Breaker : in out Special_Breaker ) is ---------- m + begin + TCTouch.Touch( 'm' ); + case Status_Of( C393001_1.Breaker( The_Breaker )) is + when C393001_1.Failed => + C393001_2.Fail( The_Breaker.Backup ); + when others => + C393001_2.Fail( C393001_2.Basic_Breaker( The_Breaker )); + C393001_2.Reset( The_Breaker.Backup ); + end case; + end Fail; + + function Status_Of( The_Breaker : Special_Breaker ) ----------------- n + return C393001_1.Status is + begin + TCTouch.Touch( 'n' ); + case Status_Of( C393001_1.Breaker( The_Breaker )) is + when C393001_1.Power_On => return C393001_1.Power_On; + when C393001_1.Power_Off => return C393001_1.Power_Off; + when others => + return C393001_2.Status_Of( The_Breaker.Backup ); + end case; + end Status_Of; + + function On_Backup( The_Breaker : Special_Breaker ) return Boolean is + use C393001_2; + use type C393001_1.Status; + begin + return Status_Of(Basic_Breaker(The_Breaker)) = C393001_1.Tripped + or Status_Of(Basic_Breaker(The_Breaker)) = C393001_1.Failed; + end On_Backup; + +end C393001_4; + +------------------------------------------------------------------- C393001 + +with Report, TCTouch; +with C393001_1, C393001_2, C393001_3, C393001_4; +procedure C393001 is + + procedure Flipper( The_Circuit : in out C393001_1.Breaker'Class ) is + begin + C393001_1.Flip( The_Circuit ); + end Flipper; + + procedure Tripper( The_Circuit : in out C393001_1.Breaker'Class ) is + begin + C393001_1.Trip( The_Circuit ); + end Tripper; + + procedure Restore( The_Circuit : in out C393001_1.Breaker'Class ) is + begin + C393001_1.Reset( The_Circuit ); + end Restore; + + procedure Failure( The_Circuit : in out C393001_1.Breaker'Class ) is + begin + C393001_1.Fail( The_Circuit ); + end Failure; + + Short : C393001_1.Breaker'Class -- Basic_Breaker + := C393001_2.Construct( C393001_2.V440, C393001_2.A5 ); + Sharp : C393001_1.Breaker'Class -- Ground_Fault + := C393001_3.Construct( C393001_2.V110, C393001_2.A1 ); + Shock : C393001_1.Breaker'Class -- Special_Breaker + := C393001_4.Construct( C393001_2.V12, C393001_2.A100 ); + +begin -- Main test procedure. + + Report.Test ("C393001", "Check that an abstract type can be declared " & + "and used. Check actual subprograms dispatch correctly" ); + + TCTouch.Validate( "cgcicc", "Declaration" ); + + Flipper( Short ); + TCTouch.Validate( "db", "Flipping Short" ); + Flipper( Sharp ); + TCTouch.Validate( "db", "Flipping Sharp" ); + Flipper( Shock ); + TCTouch.Validate( "jbdb", "Flipping Shock" ); + + Tripper( Short ); + TCTouch.Validate( "e", "Tripping Short" ); + Tripper( Sharp ); + TCTouch.Validate( "e", "Tripping Sharp" ); + Tripper( Shock ); + TCTouch.Validate( "kbfbe", "Tripping Shock" ); + + Restore( Short ); + TCTouch.Validate( "fb", "Restoring Short" ); + Restore( Sharp ); + TCTouch.Validate( "fb", "Restoring Sharp" ); + Restore( Shock ); + TCTouch.Validate( "lbfb", "Restoring Shock" ); + + Failure( Short ); + TCTouch.Validate( "a", "Shock Failing" ); + Failure( Sharp ); + TCTouch.Validate( "a", "Shock Failing" ); + Failure( Shock ); + TCTouch.Validate( "mbafb", "Shock Failing" ); + + Report.Result; + +end C393001; diff --git a/gcc-4.9/gcc/testsuite/ada/acats/tests/c3/c393007.a b/gcc-4.9/gcc/testsuite/ada/acats/tests/c3/c393007.a new file mode 100644 index 000000000..93458eeff --- /dev/null +++ b/gcc-4.9/gcc/testsuite/ada/acats/tests/c3/c393007.a @@ -0,0 +1,157 @@ +-- C393007.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. +--* +-- +-- TEST OBJECTIVE: +-- Check that an extended type can be derived from an abstract type, +-- where the abstract type is defined in a package, and the type derived +-- from it is defined in a distinct library package. +-- +-- TEST DESCRIPTION: +-- Declare an private (abstract) type; declare two primitive operations +-- of the type that are explicitly abstract. +-- Derive an extended type from the (private) abstract type, overriding +-- both of the primitive operations. +-- This test also checks to see that name overloading between abstract +-- and non-abstract functions is resolved correctly. +-- +-- +-- CHANGE HISTORY: +-- 06 Dec 94 SAIC ACVC 2.0 +-- +--! + + package C393007_0 is + -- Alert_System + + type DT_Type is new Integer; + + type Alert_Type is abstract tagged record + Time_Of_Arrival : DT_Type; + end record; + + type Log_File_Type is range 0 .. 100; + + Procedure Handle (A : in out Alert_type) is abstract; + + procedure Log (A : Alert_Type; + L : in out Log_File_Type) is abstract; + + procedure Set_Time (A : in out Alert_Type); + + function Correct_Time_Stamp (A : Alert_Type) return Boolean; + + Day_Time : DT_Type := 100; + + end C393007_0; + -- Alert_System; + + --=======================================================================-- + + package body C393007_0 is + -- Alert_System + + function Time_Stamp return DT_Type is + begin + Day_Time := Day_Time + 1; + return Day_Time; + end Time_Stamp; + + procedure Set_Time (A : in out Alert_Type) is + begin + A.Time_Of_Arrival := Time_Stamp; + end Set_time; + + function Correct_Time_Stamp ( A : Alert_Type) return Boolean is + begin + return (A.Time_Of_Arrival = Day_Time); + end Correct_Time_Stamp; + + end C393007_0; + -- Alert_System; + + --=======================================================================-- + + with Report; + with C393007_0; + -- Alert_system; + + package C393007_1 is + + type Normal_Alert_Type is + new C393007_0.Alert_Type + with null record; + + Log_File: C393007_0.Log_File_Type := C393007_0.Log_File_Type'First; + + procedure Handle (A : in out Normal_Alert_Type); -- Override is required + + procedure Log (A : Normal_Alert_Type; -- Override is required + L : in out C393007_0.Log_File_Type); + end C393007_1; + + package body C393007_1 is + use type C393007_0.Log_File_Type; + + procedure Handle (A : in out Normal_Alert_Type) is + begin + Set_Time (A); + Log (A, Log_File); + end Handle; + + procedure Log (A : Normal_Alert_Type; + L : in out C393007_0.Log_File_Type) is + begin + L := C393007_0."+"(L, 1); + end Log; + + end C393007_1; + + with Report; + with C393007_0; + with C393007_1; + -- Alert_system; + + procedure C393007 is + use C393007_0; + use C393007_1; + + Alert_One : C393007_1.Normal_Alert_Type; + + begin + Report.Test ("C393007", "Check that an extended type can be derived " & + "from an abstract type"); + + Handle (Alert_One); + if not Correct_Time_Stamp (Alert_One) then + Report.Failed ("Wrong results from procedure Handle"); + end if; + + if Log_File /=1 then + Report.Failed ("Wrong results"); + end if; + + Report.Result; + + end C393007; diff --git a/gcc-4.9/gcc/testsuite/ada/acats/tests/c3/c393008.a b/gcc-4.9/gcc/testsuite/ada/acats/tests/c3/c393008.a new file mode 100644 index 000000000..d2d2aefed --- /dev/null +++ b/gcc-4.9/gcc/testsuite/ada/acats/tests/c3/c393008.a @@ -0,0 +1,204 @@ +-- C393008.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. +--* +-- +-- TEST OBJECTIVE: +-- Check that an extended type can be derived from an abstract type. +-- +-- TEST DESCRIPTION: +-- Declare a tagged record; declare an abstract +-- primitive operation and a non-abstract primitive operation of the +-- type. Derive an extended type from it, including a new component. +-- Use the derived type, the overriding operation and the inherited +-- operation to instantiate a generic package. The overriding operation +-- calls a new primitive operation and an inherited operation [so the +-- instantiation must get this sorted out correctly]. +-- +-- +-- CHANGE HISTORY: +-- 06 Dec 94 SAIC ACVC 2.0 +-- +--! + +with Report; +with TCTouch; +procedure C393008 is + +package C393008_0 is + + type Status_Enum is (No_Status, Handled, Unhandled, Pending); + + type Alert_Type is abstract tagged record + Status : Status_Enum; + Reply : Boolean; + Urgent : Boolean; + end record; + + subtype Serial_Number is Integer range 0..Integer'last; + Serial_Num : Serial_Number := 0; + + procedure Handle (A : in out Alert_Type) is abstract; + -- abstract primitive operation + + -- the procedure Init would be _nice_ have this procedure be non_abstract + -- and create a "base" object with a "null" constraint. The language + -- will not allow this due to the restriction that an object of an + -- abstract type cannot be created. Hence Init must be abstract, + -- requiring any type derived directly from Alert_Type to declare + -- an Init. + -- + -- In light of this, I have changed init to a function to more closely + -- model the typical usage of OO features... + + function Init return Alert_Type is abstract; + + procedure No_Reply (A : in out Alert_Type); + +end C393008_0; + +--=======================================================================-- + +package body C393008_0 is + + procedure No_Reply (A : in out Alert_Type) is + begin -- primitive operation, not abstract + TCTouch.Touch('A'); ------------------------------------------------- A + if A.Status = Handled then + A.Reply := False; + end if; + end No_Reply; + +end C393008_0; + +--=======================================================================-- + + generic + -- pass in the Alert_Type object, including its + -- operations + type Data_Type is new C393008_0.Alert_Type with private; + -- note that Alert_Type is abstract, so it may not be + -- used as an actual parameter + with procedure Update (P : in out Data_Type) is <>; -- generic formal + with function Initialize return Data_Type is <>; -- generic formal + + package C393008_1 is + -- Utilities + + procedure Modify (Item : in out Data_Type); + + end C393008_1; + -- Utilities + +--=======================================================================-- + + package body C393008_1 is + -- Utilities + + procedure Modify (Item : in out Data_Type) is + begin + TCTouch.Touch('B'); --------------------------------------------- B + Item := Initialize; + Update (Item); + end Modify; + + end C393008_1; + +--=======================================================================-- + + package C393008_2 is + + type Low_Alert_Type is new C393008_0.Alert_Type with record + Serial : C393008_0.Serial_Number; + end record; + + procedure Serialize (LA : in out Low_Alert_Type); + + -- inherit No_Reply + + procedure Handle (LA : in out Low_Alert_Type); + + function Init return Low_Alert_Type; + end C393008_2; + + package body C393008_2 is + procedure Serialize (LA : in out Low_Alert_Type) is + begin -- new primitive operation + TCTouch.Touch('C'); ------------------------------------------------- C + C393008_0.Serial_Num := C393008_0.Serial_Num + 1; + LA.Serial := C393008_0.Serial_Num; + end Serialize; + + -- inherit No_Reply + + function Init return Low_Alert_Type is + TA: Low_Alert_Type; + begin + TCTouch.Touch('D'); ------------------------------------------------- D + Serialize( TA ); + TA.Status := C393008_0.No_Status; + return TA; + end Init; + + procedure Handle (LA : in out Low_Alert_Type) is + begin -- overrides abstract inherited Handle + TCTouch.Touch('E'); ------------------------------------------------- E + Serialize (LA); + LA.Reply := False; + LA.Status := C393008_0.Handled; + No_Reply (LA); + end Handle; + + end C393008_2; + + use C393008_2; + + package Alert_Utilities is new + C393008_1 (Data_Type => Low_Alert_Type, + Update => Handle, -- Low_Alert's Handle + Initialize => Init); -- inherited from Alert + + Item : Low_Alert_Type; + + use type C393008_0.Status_Enum; + +begin + + Report.Test ("C393008", "Check that an extended type can be derived "& + "from an abstract type"); + + Item := Init; + if (Item.Status /= C393008_0.No_Status) or (Item.Serial /=1) then + Report.Failed ("Wrong initialization"); + end if; + TCTouch.Validate("DC", "Initialization Call"); + + Alert_Utilities.Modify (Item); + if (Item.Status /= C393008_0.Handled) or (Item.Serial /= 3) then + Report.Failed ("Wrong results from Modify"); + end if; + TCTouch.Validate("BDCECA", "Generic Instance Call"); + + Report.Result; + +end C393008; diff --git a/gcc-4.9/gcc/testsuite/ada/acats/tests/c3/c393009.a b/gcc-4.9/gcc/testsuite/ada/acats/tests/c3/c393009.a new file mode 100644 index 000000000..1353f9c37 --- /dev/null +++ b/gcc-4.9/gcc/testsuite/ada/acats/tests/c3/c393009.a @@ -0,0 +1,170 @@ +-- C393009.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. +--* +-- +-- TEST OBJECTIVE: +-- Check that an extended type can be derived from an abstract type. +-- +-- TEST DESCRIPTION: +-- Declare an abstract type in the specification of a generic package. +-- Instantiate the package and derive an extended type from the abstract +-- (instantiated) type; override all abstract operations; use all +-- inherited operations; +-- +-- +-- CHANGE HISTORY: +-- 06 Dec 94 SAIC ACVC 2.0 +-- 14 Oct 95 SAIC Fixed for ACVC 2.0.1 +-- +--! + +with Report; +procedure C393009 is + + package Display_Devices is + + type Display_Device_Enum is (None, TTY, Console, Big_Screen); + Display : Display_Device_Enum := None; + + end Display_Devices; + +--=======================================================================-- + + generic + + type Generic_Status is (<>); + + type Serial_Type is (<>); + + package Alert_System is + + type Alert_Type (Serial : Serial_Type) is abstract tagged record + Status : Generic_Status; + end record; + + Next_Serial_Number : Serial_Type := Serial_Type'First; + + procedure Handle (A : in out Alert_Type) is abstract; + -- abstract operation - must be overridden after instantiation + + procedure Display ( A : Alert_Type; + On : Display_Devices.Display_Device_Enum); + -- primitive operation of Alert_Type + -- not required to be overridden + + function Get_Serial_Number (A : Alert_Type) return Serial_Type; + -- primitive operation of Alert_Type + -- not required to be overridden + + end Alert_System; + +--=======================================================================-- + + package body Alert_System is + + procedure Display ( A : in Alert_Type; + On : Display_Devices.Display_Device_Enum) is + begin + Display_Devices.Display := On; + end Display; + + function Get_Serial_Number (A : Alert_Type) + return Serial_Type is + begin + return A.Serial; + end Get_Serial_Number; + + end Alert_System; + +--=======================================================================-- + + package NCC_1701 is + + type Status_Kind is (Green, Yellow, Red); + type Serial_Number_Type is new Integer range 1..Integer'Last; + + subtype Msg_Str is String (1..16); + Alert_Msg : Msg_Str := "C393009 passed."; + -- 123456789A123456 + + package Alert_Pkg is new Alert_System (Status_Kind, Serial_Number_Type); + + type New_Alert_Type(Serial : Serial_Number_Type) is + new Alert_Pkg.Alert_Type(Serial) with record + Message : Msg_Str; + end record; + + -- procedure Display is inherited by New_Alert_Type + + -- function Get_Serial_Number is inherited by New_Alert_Type + procedure Handle (NA : in out New_Alert_Type); -- must be overridden + procedure Init (NA : in out New_Alert_Type); -- new primitive + + NA : New_Alert_Type(Alert_Pkg.Next_Serial_Number); + -- New_Alert_Type is not abstract, so an object of that + -- type may be declared + + end NCC_1701; + + package body NCC_1701 is + + procedure Handle (NA : in out New_Alert_Type) is + begin + NA.Message := Alert_Msg; + Display (NA, On => Display_Devices.TTY); + end Handle; + + procedure Init (NA : in out New_Alert_Type) is -- new primitive operation + begin -- for New_Alert_Type + NA := (Serial=> NA.Serial, Status => Green, Message => (others => ' ')); + end Init; + + end NCC_1701; + + use NCC_1701; + use type Display_Devices.Display_Device_Enum; + +begin + + Report.Test ("C393009", "Check that an extended type can be derived " & + "from an abstract type"); + + Init (NA); + if (Get_Serial_Number (NA) /= 1) + or (NA.Status /= Green) + or (Display_Devices.Display /= Display_Devices.None) then + Report.Failed ("Wrong Initialization"); + end if; + + Handle (NA); + if (Get_Serial_Number (NA) /= 1) + or (NA.Status /= Green) + or (NA.Message /= Alert_Msg) + or (Display_Devices.Display /= Display_Devices.TTY) then + Report.Failed ("Wrong results from Handle"); + end if; + + Report.Result; + +end C393009; diff --git a/gcc-4.9/gcc/testsuite/ada/acats/tests/c3/c393010.a b/gcc-4.9/gcc/testsuite/ada/acats/tests/c3/c393010.a new file mode 100644 index 000000000..6a52cf889 --- /dev/null +++ b/gcc-4.9/gcc/testsuite/ada/acats/tests/c3/c393010.a @@ -0,0 +1,306 @@ +-- C393010.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. +--* +-- +-- TEST OBJECTIVE: +-- Check that an extended type can be derived from an abstract type and +-- that a call on an abstract operation is a dispatching operation. +-- Check that such a call can dispatch to an overriding operation +-- declared in the private part of a package. +-- +-- TEST DESCRIPTION: +-- Taking from a classroom example of a typical usage: declare a basic +-- abstract type containing data germane to the entire class structure, +-- derive from that a type with specific data, and derive from that +-- another type merely providing a "secret" override. The abstract type +-- provides a concrete procedure that itself "redispatches" to an +-- abstract procedure; the abstract procedure must be provided by one or +-- more of the concrete types derived from the abstract type, and hence +-- upon re-evaluating the actual type of the operand should dispatch +-- accordingly. +-- +-- +-- +-- CHANGE HISTORY: +-- 06 Dec 94 SAIC ACVC 2.0 +-- 15 Mar 96 SAIC ACVC 2.1 +-- +--! + +----------------------------------------------------------------- C393010_0 + +package C393010_0 is + + type Ticket is abstract tagged record + Flight : Natural; + Serial_Number : Natural; + end record; + + function Issue return Ticket is abstract; + procedure Label( T: Ticket ) is abstract; + + procedure Print( T: Ticket ); + +end C393010_0; + +with TCTouch; +package body C393010_0 is + + procedure Print( T: Ticket ) is + begin + -- Check that a call on an abstract operation is a dispatching operation + Label( Ticket'Class( T ) ); + -- Appropriate_IO.Put( T.Flight & T.Serial_Number ); + TCTouch.Touch('P'); -------------------------------------------------- P + end Print; + +end C393010_0; + +----------------------------------------------------------------- C393010_1 + +with C393010_0; +package C393010_1 is + + type Service_Classes is (First, Business, Coach); + + type Menu is (Steak, Lobster, Fowl, Vegan); + + -- Check that an extended type can be derived from an abstract type. + type Passenger_Ticket(Service : Service_Classes) is + new C393010_0.Ticket with record + Row_Seat : String(1..3); + case Service is + when First | Business => Meal : Menu; + when Coach => null; + end case; + end record; + + function Issue return Passenger_Ticket; + function Issue( Service : Service_Classes; + Flight : Natural; + Seat : String; + Meal : Menu := Fowl ) return Passenger_Ticket; + + procedure Label( T: Passenger_Ticket ); + + procedure Print( T: Passenger_Ticket ); + +end C393010_1; + +with TCTouch; +package body C393010_1 is + + procedure Label( T: Passenger_Ticket ) is + begin + -- Appropriate_IO.Put( T.Service ); + TCTouch.Touch('L'); -------------------------------------------------- L + end Label; + + procedure Print( T: Passenger_Ticket ) is + begin + -- call parent print: + C393010_0.Print( C393010_0.Ticket( T ) ); + case T.Service is + when First => -- Appropriate_IO.Put( Meal ); + TCTouch.Touch('F'); ---------------------------------------------- F + when Business => -- Appropriate_IO.Put( Meal ); + TCTouch.Touch('B'); ---------------------------------------------- B + when Coach => -- Appropriate_IO.Put( "BYO" & " peanuts" ); + TCTouch.Touch('C'); ---------------------------------------------- C + end case; + end Print; + + Num : Natural := 1000; + + function Issue( Service : Service_Classes; + Flight : Natural; + Seat : String; + Meal : Menu := Fowl ) return Passenger_Ticket is + begin + Num := Num +1; + case Service is + when First => + return Passenger_Ticket'(Service => First, Flight => Flight, + Row_Seat => Seat, Meal => Meal, Serial_Number => Num ); + when Business => + return Passenger_Ticket'(Service => Business, Flight => Flight, + Row_Seat => Seat, Meal => Meal, Serial_Number => Num ); + when Coach => + return Passenger_Ticket'(Service => Coach, Flight => Flight, + Row_Seat => Seat, Serial_Number => Num ); + end case; + end Issue; + + function Issue return Passenger_Ticket is + begin + return Issue( Coach, 0, "non" ); + end Issue; + +end C393010_1; + +----------------------------------------------------------------- C393010_1 + +with C393010_1; +package C393010_2 is + + type Charter is new C393010_1.Passenger_Ticket( C393010_1.Coach ) + with private; + + function Issue return Charter; + + -- procedure Print( T: Passenger_Ticket ); + +private + type Charter is new C393010_1.Passenger_Ticket( C393010_1.Coach ) + with null record; + + -- Check that the dispatching call to the abstract operation will dispatch + -- to a procedure defined in the private part of a package. + procedure Label( T: Charter ); + + -- an example of a required function the users shouldn't see: + function Issue( Service : C393010_1.Service_Classes; + Flight : Natural; + Seat : String; + Meal : C393010_1.Menu ) return Charter; + +end C393010_2; + +with TCTouch; +package body C393010_2 is + + procedure Label( T: Charter ) is + begin + -- Appropriate_IO.Put( "Excursion Fare" ); + TCTouch.Touch('X'); -------------------------------------------------- X + end Label; + + Num : Natural := 4000; + + function Issue return Charter is + begin + Num := Num +1; + return Charter'(Service => C393010_1.Coach, Flight => 1001, + Row_Seat => "OPN", Serial_Number => Num ); + end Issue; + + function Issue( Service : C393010_1.Service_Classes; + Flight : Natural; + Seat : String; + Meal : C393010_1.Menu ) return Charter is + begin + return Issue; + end Issue; + +end C393010_2; + +----------------------------------------------------------------- C393010_1 + +with Report; +with TCTouch; +with C393010_0; +with C393010_1; +with C393010_2; -- Charter Tours + +procedure C393010 is + + type Agents_Handle is access all C393010_0.Ticket'Class; + + type Itinerary; + + type Next_Leg is access Itinerary; + + type Itinerary is record + Leg : Agents_Handle; + Next : Next_Leg; + end record; + + function Travel_Agent_1 return Next_Leg is + begin + -- ORL -> JFK -> LAX -> SAN -> DFW -> ORL + return new Itinerary'( + -- ORL -> JFK 01 12 2A First, Lobster + new C393010_1.Passenger_Ticket'( + C393010_1.Issue(C393010_1.First, 12, " 2A", C393010_1.Lobster )), + new Itinerary'( + -- JFK -> LAX 02 18 2B First, Steak + new C393010_1.Passenger_Ticket'( + C393010_1.Issue(C393010_1.First, 18, " 2B", C393010_1.Steak )), + new Itinerary'( + -- LAX -> SAN 03 5225 34H Coach + new C393010_1.Passenger_Ticket'( + C393010_1.Issue(C393010_1.Coach, 5225, "34H")), + new Itinerary'( + -- SAN -> DFW 04 25 13A Business, Fowl + new C393010_1.Passenger_Ticket'( + C393010_1.Issue(C393010_1.Business, 25, "13A")), + new Itinerary'( + -- DFW -> ORL 05 15 1D First, Lobster + new C393010_1.Passenger_Ticket'( + C393010_1.Issue(C393010_1.First, 15, " 1D", C393010_1.Lobster )), + null ))))); + end Travel_Agent_1; + + function Travel_Agent_2 return Next_Leg is + begin + -- LAX -> NRT -> SYD -> LAX + return new Itinerary'( + new C393010_2.Charter'( C393010_2.Issue ), + new Itinerary'( + new C393010_2.Charter'( C393010_2.Issue ), + new Itinerary'( + new C393010_2.Charter'( C393010_2.Issue ), + new Itinerary'( + new C393010_2.Charter'( C393010_2.Issue ), + null )))); + end Travel_Agent_2; + + procedure Traveler( Pax_Tix : in Next_Leg ) is + Fly_Me : Next_Leg := Pax_Tix; + begin + -- a particularly consumptive process... + while Fly_Me /= null loop + C393010_0.Print( Fly_Me.Leg.all ); -- herein lies the test. + Fly_Me := Fly_Me.Next; + end loop; + end Traveler; + +begin + + Report.Test ("C393010", "Check that an extended type can be derived from " + & "an abstract type and that a call on an abstract " + & "operation is a dispatching operation. Check " + & "that such a call can dispatch to an overriding " + & "operation declared in the private part of a " + & "package" ); + + Traveler( Travel_Agent_1 ); + TCTouch.Validate("LPFLPFLPCLPBLPF","First Trip"); + + Traveler( Travel_Agent_2 ); + TCTouch.Validate("XPCXPCXPCXPC","Second Trip"); + + Report.Result; + +end C393010; diff --git a/gcc-4.9/gcc/testsuite/ada/acats/tests/c3/c393011.a b/gcc-4.9/gcc/testsuite/ada/acats/tests/c3/c393011.a new file mode 100644 index 000000000..8741e87c1 --- /dev/null +++ b/gcc-4.9/gcc/testsuite/ada/acats/tests/c3/c393011.a @@ -0,0 +1,220 @@ +-- C393011.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. +--* +-- +-- TEST OBJECTIVE: +-- Check that an abstract extended type can be derived from an abstract +-- type, and that a a non-abstract type may then be derived from the +-- second abstract type. +-- +-- TEST DESCRIPTION: +-- Define an abstract type with three primitive operations, two of them +-- abstract. Derive an extended type from it, inheriting the non- +-- abstract operation, overriding one of the abstract operations with +-- a non-abstract operation, and overriding the other abstract operation +-- with an abstract operation. The extended type is therefore abstract; +-- derive an extended type from it. Override the abstract operation with +-- a non-abstract operation; inherit one operation from the original +-- abstract type, and inherit one operation from the intermediate +-- abstract type. +-- +-- +-- CHANGE HISTORY: +-- 06 Dec 94 SAIC ACVC 2.0 +-- +--! + + Package C393011_0 is + -- Definitions + + type Status_Enum is (None, Unhandled, Pending, Handled); + type Serial_Type is new Integer range 0 .. Integer'Last; + subtype Priority_Type is Integer range 0..10; + + type Display_Enum is (Bit_Bucket, TTY, Console, Big_Screen); + + Next : Serial_Type := 1; + Display_Device : Display_Enum := Bit_Bucket; + + end C393011_0; + -- Definitions; + + --=======================================================================-- + + with C393011_0; + -- Definitions + + Package C393011_1 is + -- Alert + + package Definitions renames C393011_0; + + type Alert_Type is abstract tagged record + Status : Definitions.Status_Enum := Definitions.None; + Serial_Num : Definitions.Serial_Type := 0; + Priority : Definitions.Priority_Type; + end record; + -- Alert_Type is an abstract type with + -- two operations to be overridden + + procedure Set_Status ( A : in out Alert_Type; -- not abstract + To : Definitions.Status_Enum); + + procedure Set_Serial ( A : in out Alert_Type) is abstract; + procedure Display ( A : Alert_Type) is abstract; + + end C393011_1; + -- Alert + + --=======================================================================-- + + with C393011_0; + package body C393011_1 is + -- Alert + procedure Set_Status ( A : in out Alert_Type; + To : Definitions.Status_Enum) is + begin + A.Status := To; + end Set_Status; + + end C393011_1; + -- Alert; + + --=======================================================================-- + + with C393011_0, + -- Definitions, + C393011_1, + -- Alert, + Calendar; + + Package C393011_3 is + -- New_Alert + + type New_Alert_Type is abstract new C393011_1.Alert_Type with record + Display_Dev : C393011_0.Display_Enum := C393011_0.TTY; + end record; + + -- procedure Set_Status is inherited + + procedure Set_Serial ( A : in out New_Alert_Type); -- override/see body + + procedure Display ( A : New_Alert_Type) is abstract; + -- override is abstract + -- still can't declare objects of New_Alert_Type + + end C393011_3; + -- New_Alert + + --=======================================================================-- + + with C393011_0; + Package Body C393011_3 is + -- New_Alert + + package Definitions renames C393011_0; + + procedure Set_Serial (A : in out New_Alert_Type) is + use type Definitions.Serial_Type; + begin + A.Serial_Num := Definitions.Next; + Definitions.Next := Definitions."+"( Definitions.Next, 1); + end Set_Serial; + + End C393011_3; + -- New_Alert; + + --=======================================================================-- + + with C393011_0, + -- Definitions + C393011_3; + -- New_Alert -- package Alert is not visible + package C393011_4 is + + package New_Alert renames C393011_3; + package Definitions renames C393011_0; + + type Final_Alert_Type is new New_Alert.New_Alert_Type with null record; + -- inherits Set_Status including body + -- inherits Set_Serial including body + -- must override Display since inherited Display is abstract + procedure Display(FA : in Final_Alert_Type); + procedure Handle (FA : in out Final_Alert_Type); + + end C393011_4; + + package body C393011_4 is + + procedure Display (FA : in Final_Alert_Type) is + begin + Definitions.Display_Device := FA.Display_Dev; + end Display; + + procedure Handle (FA : in out Final_Alert_Type) is + begin + Set_Status (FA, Definitions.Handled); + Set_Serial (FA); + Display (FA); + end Handle; + end C393011_4; + + with C393011_0, + -- Definitions + C393011_3; + -- New_Alert -- package Alert is not visible + with C393011_4; + with Report; + procedure C393011 is + use C393011_4; + use Definitions; + + FA : Final_Alert_Type; + + begin + + Report.Test ("C393011", "Check that an extended type can be derived " & + "from an abstract type"); + + if (Definitions.Display_Device /= Definitions.Bit_Bucket) + or (Definitions.Next /= 1) + or (FA.Status /= Definitions.None) + or (FA.Serial_Num /= 0) + or (FA.Display_Dev /= TTY) then + Report.Failed ("Incorrect initial conditions"); + end if; + + Handle (FA); + if (Definitions.Display_Device /= Definitions.TTY) + or (Definitions.Next /= 2) + or (FA.Status /= Definitions.Handled) + or (FA.Serial_Num /= 1) + or (FA.Display_Dev /= TTY) then + Report.Failed ("Incorrect results from Handle"); + end if; + + Report.Result; + + end C393011; + diff --git a/gcc-4.9/gcc/testsuite/ada/acats/tests/c3/c393012.a b/gcc-4.9/gcc/testsuite/ada/acats/tests/c3/c393012.a new file mode 100644 index 000000000..16bf6ddcc --- /dev/null +++ b/gcc-4.9/gcc/testsuite/ada/acats/tests/c3/c393012.a @@ -0,0 +1,221 @@ +-- C393012.A +-- +-- Grant of Unlimited Rights +-- +-- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687, +-- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained +-- unlimited rights in the software and documentation contained herein. +-- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making +-- this public release, the Government intends to confer upon all +-- recipients unlimited rights equal to those held by the Government. +-- These rights include rights to use, duplicate, release or disclose the +-- released technical data and computer software in whole or in part, in +-- any manner and for any purpose whatsoever, and to have or permit others +-- to do so. +-- +-- DISCLAIMER +-- +-- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR +-- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED +-- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE +-- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE +-- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A +-- PARTICULAR PURPOSE OF SAID MATERIAL. +--* +-- +-- OBJECTIVE: +-- Check that a non-abstract subprogram of an abstract type can be +-- called with a controlling operand that is a type conversion to +-- the abstract type. +-- +-- Check that converting to the class-wide type of an abstract type +-- inside an operation of that type causes a "redispatch" of the +-- called operation. +-- +-- TEST DESCRIPTION: +-- This test defines an abstract type, and further derives types from it. +-- The key feature of this test is in the "Display" procedures where +-- the bodies of these procedures convert an object to the class-wide +-- type of the root abstract type, causing a "redispatch". +-- +-- +-- CHANGE HISTORY: +-- 06 Dec 94 SAIC ACVC 2.0 +-- 16 Dec 94 SAIC Add allocation to the object initializations +-- +--! + +package C393012_0 is + + subtype Row_Number is Positive range 1..120; + subtype Seat_Letter is Character range 'A'..'M'; + + type Ticket is abstract tagged + record + Flight : Natural; + Row : Row_Number; + Seat : Seat_Letter; + end record; + + function Display( T: Ticket ) return String; + function Service( T: Ticket ) return String is abstract; + +end C393012_0; + +with TCTouch; +package body C393012_0 is + function Display( T: Ticket ) return String is + begin + TCTouch.Touch('T'); --------------------------------------------------- T + return "Fl:" & Natural'Image(T.Flight) + & Service( Ticket'Class( T ) ) + & " Seat:" & Row_Number'Image(T.Row) & T.Seat; + end Display; +end C393012_0; + +with C393012_0; +package C393012_1 is + type Economy is new C393012_0.Ticket with null record; + function Display( T: Economy ) return String; + function Service( T: Economy ) return String; + + type Meal_Designator is ( B, L, D, V, SN ); + + type First is new C393012_0.Ticket with + record + Meal : Meal_Designator; + end record; + function Display( T: First ) return String; + function Service( T: First ) return String; + procedure Set_Meal( T: in out First; To_Meal : Meal_Designator ); + +end C393012_1; + +with TCTouch; +package body C393012_1 is + function Display( T: Economy ) return String is + begin + TCTouch.Touch('E'); --------------------------------------------------- E + return C393012_0.Display( C393012_0.Ticket( T ) ); + end Display; -- conversion to abstract type + + function Service( T: Economy ) return String is + begin + TCTouch.Touch('e'); --------------------------------------------------- e + return " K"; + end Service; + + function Display( T: First ) return String is + begin + TCTouch.Touch('F'); --------------------------------------------------- F + return C393012_0.Display( C393012_0.Ticket( T ) ); + end Display; -- conversion to abstract type + + function Service( T: First ) return String is + begin + TCTouch.Touch('f'); --------------------------------------------------- f + return " F" & Meal_Designator'Image(T.Meal); + end Service; + + procedure Set_Meal( T: in out First; To_Meal : Meal_Designator ) is + begin + T.Meal := To_Meal; + end Set_Meal; + +end C393012_1; + +with Report; +with TCTouch; +with C393012_0; +with C393012_1; +procedure C393012 is + + package Rt renames C393012_0; + package Tx renames C393012_1; + + type Tix is access Rt.Ticket'Class; + type Itinerary is array(Positive range 1..3) of Tix; + +-- Outbound and Inbound itineraries provide different orderings of mixtures +-- of Economy and First_Class. Not that that should make any difference... + + Outbound : Itinerary := ( 1 => new Tx.Economy'( 5335, 5, 'B' ), + 2 => new Tx.First' ( 67, 1, 'J', Tx.L ), + 3 => new Tx.Economy'( 345, 37, 'C' ) ); + + Inbound : Itinerary := ( 1 => new Tx.First' ( 456, 4, 'F', Tx.SN ), + 2 => new Tx.Economy'( 68, 12, 'D' ), + 3 => new Tx.Economy'( 5336, 6, 'A' ) ); + +-- Each call to Display uses a parameter that is a type conversion +-- to the abstract type Ticket. + + procedure TC_Convert( I: Itinerary; Leg1,Leg2,Leg3: String ) is + begin + if Rt.Display( Rt.Ticket( I(1).all ) ) /= Leg1 then + Report.Failed( Rt.Display( Rt.Ticket( I(1).all ) ) & " /= " & Leg1 ); + end if; + if Rt.Display( Rt.Ticket( I(2).all ) ) /= Leg2 then + Report.Failed( Rt.Display( Rt.Ticket( I(2).all ) ) & " /= " & Leg2 ); + end if; + if Rt.Display( Rt.Ticket( I(3).all ) ) /= Leg3 then + Report.Failed( Rt.Display( Rt.Ticket( I(3).all ) ) & " /= " & Leg3 ); + end if; + end TC_Convert; + +-- Each call to Display uses a parameter that is not a type conversion + + procedure TC_Match( I: Itinerary; Leg1,Leg2,Leg3: String ) is + begin + if Rt.Display( I(1).all ) /= Leg1 then + Report.Failed( Rt.Display( I(1).all ) & " /= " & Leg1 ); + end if; + if Rt.Display( I(2).all ) /= Leg2 then + Report.Failed( Rt.Display( I(2).all ) & " /= " & Leg2 ); + end if; + if Rt.Display( I(3).all ) /= Leg3 then + Report.Failed( Rt.Display( I(3).all ) & " /= " & Leg3 ); + end if; + end TC_Match; + +begin -- Main test procedure. + + Report.Test ("C393012", "Check that a non-abstract subprogram of an " + & "abstract type can be called with a " + & "controlling operand that is a type " + & "conversion to the abstract type. " + & "Check that converting to the class-wide type " + & "of an abstract type inside an operation of " + & "that type causes a redispatch" ); + + -- Test conversions to abstract type + + TC_Convert( Outbound, "Fl: 5335 K Seat: 5B", + "Fl: 67 FL Seat: 1J", + "Fl: 345 K Seat: 37C" ); + + TCTouch.Validate( "TeTfTe", "Outbound flight (converted)" ); + + TC_Convert( Inbound, "Fl: 456 FSN Seat: 4F", + "Fl: 68 K Seat: 12D", + "Fl: 5336 K Seat: 6A" ); + + TCTouch.Validate( "TfTeTe", "Inbound flight (converted)" ); + + -- Test without conversions to abstract type + + TC_Match( Outbound, "Fl: 5335 K Seat: 5B", + "Fl: 67 FL Seat: 1J", + "Fl: 345 K Seat: 37C" ); + + TCTouch.Validate( "ETeFTfETe", "Outbound flight" ); + + TC_Match( Inbound, "Fl: 456 FSN Seat: 4F", + "Fl: 68 K Seat: 12D", + "Fl: 5336 K Seat: 6A" ); + + TCTouch.Validate( "FTfETeETe", "Inbound flight" ); + + Report.Result; + +end C393012; diff --git a/gcc-4.9/gcc/testsuite/ada/acats/tests/c3/c393a02.a b/gcc-4.9/gcc/testsuite/ada/acats/tests/c3/c393a02.a new file mode 100644 index 000000000..177bd34b8 --- /dev/null +++ b/gcc-4.9/gcc/testsuite/ada/acats/tests/c3/c393a02.a @@ -0,0 +1,213 @@ +-- C393A02.A +-- +-- Grant of Unlimited Rights +-- +-- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687, +-- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained +-- unlimited rights in the software and documentation contained herein. +-- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making +-- this public release, the Government intends to confer upon all +-- recipients unlimited rights equal to those held by the Government. +-- These rights include rights to use, duplicate, release or disclose the +-- released technical data and computer software in whole or in part, in +-- any manner and for any purpose whatsoever, and to have or permit others +-- to do so. +-- +-- DISCLAIMER +-- +-- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR +-- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED +-- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE +-- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE +-- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A +-- PARTICULAR PURPOSE OF SAID MATERIAL. +--* +-- +-- OBJECTIVE: +-- Check that a dispatching call to an abstract subprogram invokes +-- the correct subprogram body of a descendant type according to +-- the controlling tag. +-- Check that a subprogram can be declared with formal parameters +-- and result that are of an abstract type's associated class-wide +-- type and that such subprograms can be called. 3.4.1(4) +-- +-- TEST DESCRIPTION: +-- This test declares several objects of types derived from the +-- abstract type as defined in the foundation F393A00. It then calls +-- various dispatching and class-wide subprograms using those objects. +-- The packages in F393A00 are instrumented to trace the flow of +-- execution. +-- The test checks for the correct order of execution, as expected +-- by the various calls. +-- +-- TEST FILES: +-- The following files comprise this test: +-- +-- F393A00.A (foundation code) +-- C393A02.A +-- +-- +-- CHANGE HISTORY: +-- 06 Dec 94 SAIC ACVC 2.0 +-- 19 Dec 94 SAIC Removed RM references from objective text. +-- 05 APR 96 SAIC Update RM references for 2.1 +-- +--! + +with Report; +with F393A00_0; +with F393A00_1; +with F393A00_2; +with F393A00_3; +with F393A00_4; +procedure C393A02 is + + A_Windmill : F393A00_2.Windmill; + A_Pump : F393A00_3.Pump; + A_Mill : F393A00_4.Mill; + + A_Windmill_2 : F393A00_2.Windmill; + A_Pump_2 : F393A00_3.Pump; + A_Mill_2 : F393A00_4.Mill; + + B_Windmill : F393A00_2.Windmill; + B_Pump : F393A00_3.Pump; + B_Mill : F393A00_4.Mill; + + procedure Swapem( A,B: in out F393A00_2.Windmill'Class ) is + begin + F393A00_0.TC_Touch('x'); + F393A00_2.Swap( A,B ); + end Swapem; + + function Zephyr( A: F393A00_2.Windmill'Class ) + return F393A00_2.Windmill'Class is + Item : F393A00_2.Windmill'Class := A; + begin + F393A00_0.TC_Touch('y'); + if not F393A00_1.Initialized( Item ) then -- b + F393A00_2.Initialize( Item ); -- a + end if; + F393A00_2.Stop( Item ); -- f / mff + F393A00_2.Add_Spin( Item, 10 ); -- e + return Item; + end Zephyr; + + function Gale( It: F393A00_2.Windmill ) return F393A00_2.Windmill'Class is + Item : F393A00_2.Windmill'Class := It; + begin + F393A00_2.Stop( Item ); -- f + F393A00_2.Add_Spin( Item, 40 ); -- e + return Item; + end Gale; + + function Gale( It: F393A00_3.Pump ) return F393A00_2.Windmill'Class is + Item : F393A00_2.Windmill'Class := It; + begin + F393A00_2.Stop( Item ); -- f + F393A00_2.Add_Spin( Item, 50 ); -- e + return Item; + end Gale; + + function Gale( It: F393A00_4.Mill ) return F393A00_2.Windmill'Class is + Item : F393A00_2.Windmill'Class := It; + begin + F393A00_2.Stop( Item ); -- mff + F393A00_2.Add_Spin( Item, 60 ); -- e + return Item; + end Gale; + +begin -- Main test procedure. + + Report.Test ("C393A02", "Check that a dispatching call to an abstract " + & "subprogram invokes the correct subprogram body. " + & "Check that a subprogram declared with formal " + & "parameters/result of an abstract type's " + & "associated class-wide can be called" ); + + F393A00_0.TC_Validate( "hhh", "Mill declarations" ); + A_Windmill := F393A00_2.Create; + F393A00_0.TC_Validate( "d", "Create A_Windmill" ); + + A_Pump := F393A00_3.Create; + F393A00_0.TC_Validate( "h", "Create A_Pump" ); + + A_Mill := F393A00_4.Create; + F393A00_0.TC_Validate( "hl", "Create A_Mill" ); + + -------------- + + Swapem( A_Windmill, A_Windmill_2 ); + F393A00_0.TC_Validate( "xc", "Windmill Swap" ); + + Swapem( A_Pump, A_Pump_2 ); + F393A00_0.TC_Validate( "xc", "Pump Swap" ); + + Swapem( A_Mill, A_Mill_2 ); + F393A00_0.TC_Validate( "xk", "Pump Swap" ); + + F393A00_2.Initialize( A_Windmill_2 ); + F393A00_3.Initialize( A_Pump_2 ); + F393A00_4.Initialize( A_Mill_2 ); + B_Windmill := A_Windmill_2; + B_Pump := A_Pump_2; + B_Mill := A_Mill_2; + F393A00_2.Add_Spin( B_Windmill, 123 ); + F393A00_3.Set_Rate( B_Pump, 12.34 ); + F393A00_4.Add_Spin( B_Mill, 321 ); + F393A00_0.TC_Validate( "aaaeie", "Setting Values" ); + + declare + It : F393A00_2.Windmill'Class := Zephyr( B_Windmill ); -- ybfe + XX : F393A00_2.Windmill'Class := Gale( B_Windmill ); -- fe + use type F393A00_2.Rotational_Measurement; + begin + if not F393A00_1.Initialized( It ) or not F393A00_1.Initialized( XX ) +then + Report.Failed( "Copy to class-wide variable" ); + end if; -- bb + if F393A00_2.Spin( It ) /= 10 -- g + or F393A00_2.Spin( XX ) /= 40 then -- g + Report.Failed( "Call to class-wide operation" ); + end if; + + F393A00_0.TC_Validate( "ybfefebbgg", "Windmill Zephyr" ); + end; + + declare + It : F393A00_2.Windmill'Class := Zephyr( B_Pump ); -- ybfe + XX : F393A00_2.Windmill'Class := Gale( B_Pump ); -- fe + use type F393A00_2.Rotational_Measurement; + begin + if not F393A00_1.Initialized( It ) or not F393A00_1.Initialized( XX ) +then + Report.Failed( "Bad copy to class-wide variable" ); + end if; -- bb + if F393A00_2.Spin( It ) /= 10 -- g + or F393A00_2.Spin( XX ) /= 50 then -- g + Report.Failed( "Call to class-wide operation" ); + end if; + + F393A00_0.TC_Validate( "ybfefebbgg", "Pump Zephyr" ); + end; + + declare + It : F393A00_2.Windmill'Class := Zephyr( B_Mill ); -- ybmffe + XX : F393A00_2.Windmill'Class := Gale( B_Mill ); -- mffe + use type F393A00_2.Rotational_Measurement; + begin + if not F393A00_1.Initialized( It ) or not F393A00_1.Initialized( XX ) +then + Report.Failed( "Bad copy to class-wide variable" ); + end if; -- bb + if F393A00_2.Spin( It ) /= 10 -- g + or F393A00_2.Spin( XX ) /= 60 then -- g + Report.Failed( "Call to class-wide operation" ); + end if; + + F393A00_0.TC_Validate( "ybmffemffebbgg", "Mill Zephyr" ); + end; + + Report.Result; + +end C393A02; diff --git a/gcc-4.9/gcc/testsuite/ada/acats/tests/c3/c393a03.a b/gcc-4.9/gcc/testsuite/ada/acats/tests/c3/c393a03.a new file mode 100644 index 000000000..90106f4bf --- /dev/null +++ b/gcc-4.9/gcc/testsuite/ada/acats/tests/c3/c393a03.a @@ -0,0 +1,242 @@ +-- C393A03.A +-- +-- Grant of Unlimited Rights +-- +-- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687, +-- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained +-- unlimited rights in the software and documentation contained herein. +-- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making +-- this public release, the Government intends to confer upon all +-- recipients unlimited rights equal to those held by the Government. +-- These rights include rights to use, duplicate, release or disclose the +-- released technical data and computer software in whole or in part, in +-- any manner and for any purpose whatsoever, and to have or permit others +-- to do so. +-- +-- DISCLAIMER +-- +-- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR +-- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED +-- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE +-- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE +-- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A +-- PARTICULAR PURPOSE OF SAID MATERIAL. +--* +-- +-- OBJECTIVE: +-- Check that a non-abstract primitive subprogram of an abstract +-- type can be called as a dispatching operation and that the body +-- of this subprogram can make a dispatching call to an abstract +-- operation of the corresponding abstract type. +-- +-- TEST DESCRIPTION: +-- This test expands on the class family defined in foundation F393A00 +-- by deriving a new abstract type from the root abstract type "Object". +-- The subprograms defined for the new abstract type are then +-- appropriately overridden, and the test ultimately calls various +-- mixtures of these subprograms to check that the dispatching occurs +-- correctly. +-- +-- TEST FILES: +-- The following files comprise this test: +-- +-- F393A00.A (foundation code) +-- C393A03.A +-- +-- +-- CHANGE HISTORY: +-- 06 Dec 94 SAIC ACVC 2.0 +-- 19 Dec 94 SAIC Removed ARM references from objective text. +-- 23 Oct 95 SAIC Fixed bugs for ACVC 2.0.1 +-- +--! + +------------------------------------------------------------------- C393A03_0 + +with F393A00_1; +package C393A03_0 is + + type Counting_Object is abstract new F393A00_1.Object with private; + -- inherits Initialize, Swap (abstract) and Create (abstract) + + procedure Bump ( A_Counter: in out Counting_Object ); + procedure Clear( A_Counter: in out Counting_Object ) is abstract; + procedure Zero ( A_Counter: in out Counting_Object ); + function Value( A_Counter: Counting_Object'Class ) return Natural; + +private + + type Counting_Object is abstract new F393A00_1.Object with + record + Tally : Natural :=0; + end record; + +end C393A03_0; + +----------------------------------------------------------------------------- + +with F393A00_0; +package body C393A03_0 is + + procedure Bump ( A_Counter: in out Counting_Object ) is + begin + F393A00_0.TC_Touch('A'); + A_Counter.Tally := A_Counter.Tally +1; + end Bump; + + procedure Zero ( A_Counter: in out Counting_Object ) is + begin + F393A00_0.TC_Touch('B'); + + -- dispatching call to abstract operation of Counting_Object + Clear( Counting_Object'Class(A_Counter) ); + + A_Counter.Tally := 0; + + end Zero; + + function Value( A_Counter: Counting_Object'Class ) return Natural is + begin + F393A00_0.TC_Touch('C'); + return A_Counter.Tally; + end Value; + +end C393A03_0; + +------------------------------------------------------------------- C393A03_1 + +with C393A03_0; +package C393A03_1 is + + type Modular_Object is new C393A03_0.Counting_Object with private; + -- inherits Initialize, Bump, Zero and Value, + -- inherits abstract Swap, Create and Clear + + procedure Swap( A,B: in out Modular_Object ); + procedure Clear( It: in out Modular_Object ); + procedure Set_Max( It : in out Modular_Object; Value : Natural ); + function Create return Modular_Object; + +private + + type Modular_Object is new C393A03_0.Counting_Object with + record + Max_Value : Natural; + end record; + +end C393A03_1; + +----------------------------------------------------------------------------- + +with F393A00_0; +package body C393A03_1 is + + procedure Swap( A,B: in out Modular_Object ) is + T : constant Modular_Object := B; + begin + F393A00_0.TC_Touch('1'); + B := A; + A := T; + end Swap; + + procedure Clear( It: in out Modular_Object ) is + begin + F393A00_0.TC_Touch('2'); + null; + end Clear; + + procedure Set_Max( It : in out Modular_Object; Value : Natural ) is + begin + F393A00_0.TC_Touch('3'); + It.Max_Value := Value; + end Set_Max; + + function Create return Modular_Object is + AMO : Modular_Object; + begin + F393A00_0.TC_Touch('4'); + AMO.Max_Value := Natural'Last; + return AMO; + end Create; + +end C393A03_1; + +--------------------------------------------------------------------- C393A03 + +with Report; +with F393A00_0; +with F393A00_1; +with C393A03_0; +with C393A03_1; +procedure C393A03 is + + A_Thing : C393A03_1.Modular_Object; + Another_Thing : C393A03_1.Modular_Object; + + procedure Initialize( It: in out C393A03_0.Counting_Object'Class ) is + begin + C393A03_0.Initialize( It ); -- dispatch to inherited procedure + end Initialize; + + procedure Bump( It: in out C393A03_0.Counting_Object'Class ) is + begin + C393A03_0.Bump( It ); -- dispatch to non-abstract procedure + end Bump; + + procedure Set_Max( It : in out C393A03_1.Modular_Object'Class; + Val : Natural) is + begin + C393A03_1.Set_Max( It, Val ); -- dispatch to non-abstract procedure + end Set_Max; + + procedure Swap( A, B : in out C393A03_0.Counting_Object'Class ) is + begin + C393A03_0.Swap( A, B ); -- dispatch to inherited abstract procedure + end Swap; + + procedure Zero( It: in out C393A03_0.Counting_Object'Class ) is + begin + C393A03_0.Zero( It ); -- dispatch to non-abstract procedure + end Zero; + +begin -- Main test procedure. + + Report.Test ("C393A03", "Check that a non-abstract primitive subprogram " + & "of an abstract type can be called as a " + & "dispatching operation and that the body of this " + & "subprogram can make a dispatching call to an " + & "abstract operation of the corresponding " + & "abstract type" ); + + A_Thing := C393A03_1.Create; -- Max_Value = Natural'Last + F393A00_0.TC_Validate( "4", "Overridden primitive layer 2"); + + Initialize( A_Thing ); + Initialize( Another_Thing ); + F393A00_0.TC_Validate( "aa", "Non-abstract primitive layer 0"); + + Bump( A_Thing ); -- Tally = 1 + F393A00_0.TC_Validate( "A", "Non-abstract primitive layer 1"); + + Set_Max( A_Thing, 42 ); -- Max_Value = 42 + F393A00_0.TC_Validate( "3", "Non-abstract normal layer 2"); + + if not F393A00_1.Initialized( A_Thing ) then + Report.Failed("Initialize didn't"); + end if; + F393A00_0.TC_Validate( "b", "Class-wide layer 0"); + + Swap( A_Thing, Another_Thing ); + F393A00_0.TC_Validate( "1", "Overridden abstract layer 2"); + + Zero( A_Thing ); + F393A00_0.TC_Validate( "B2", "Non-abstract layer 0, calls dispatch"); + + if C393A03_0.Value( A_Thing ) /= 0 then + Report.Failed("Zero didn't"); + end if; + F393A00_0.TC_Validate( "C", "Class-wide normal layer 2"); + + Report.Result; + +end C393A03; diff --git a/gcc-4.9/gcc/testsuite/ada/acats/tests/c3/c393a05.a b/gcc-4.9/gcc/testsuite/ada/acats/tests/c3/c393a05.a new file mode 100644 index 000000000..b404559cc --- /dev/null +++ b/gcc-4.9/gcc/testsuite/ada/acats/tests/c3/c393a05.a @@ -0,0 +1,166 @@ +-- C393A05.A + -- +-- Grant of Unlimited Rights +-- +-- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687, +-- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained +-- unlimited rights in the software and documentation contained herein. +-- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making +-- this public release, the Government intends to confer upon all +-- recipients unlimited rights equal to those held by the Government. +-- These rights include rights to use, duplicate, release or disclose the +-- released technical data and computer software in whole or in part, in +-- any manner and for any purpose whatsoever, and to have or permit others +-- to do so. +-- +-- DISCLAIMER +-- +-- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR +-- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED +-- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE +-- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE +-- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A +-- PARTICULAR PURPOSE OF SAID MATERIAL. +--* + -- + -- OBJECTIVE: + -- Check that for a nonabstract private extension, any inherited + -- abstract subprograms can be overridden in the private part of + -- the immediately enclosing package and that calls can be made to + -- private dispatching operations. + -- + -- TEST DESCRIPTION: + -- This test builds an additional layer upon the foundation code to + -- provide the required "hidden" dispatching operation. The procedure + -- Swap, a private subprogram, should be called by dispatch. + -- + -- TEST FILES: + -- The following files comprise this test: + -- + -- F393A00.A (foundation code) + -- C393A05.A + -- + -- +-- CHANGE HISTORY: +-- 06 Dec 94 SAIC ACVC 2.0 +-- + --! + + with F393A00_4; + package C393A05_0 is + type Grinder is new F393A00_4.Mill with private; + type Coarseness is (Whole_Bean, Coarse, Medium, Fine, Espresso); + + procedure Set_Grind( It: in out Grinder; The_Grind: Coarseness ); + function Grind( It: Grinder ) return Coarseness; + + function Create return Grinder; + private + procedure Swap( A,B: in out Grinder ); + type Grinder is new F393A00_4.Mill with + record + Grind : Coarseness := Whole_Bean; + end record; + end C393A05_0; + + with F393A00_0; + package body C393A05_0 is + procedure Set_Grind( It: in out Grinder; The_Grind: Coarseness ) is + begin + F393A00_0.TC_Touch( 'A' ); + It.Grind := The_Grind; + end Set_Grind; + + function Grind( It: Grinder ) return Coarseness is + begin + F393A00_0.TC_Touch( 'B' ); + return It.Grind; + end Grind; + + procedure Swap( A,B: in out Grinder ) is + T : constant Grinder := A; + begin + F393A00_0.TC_Touch( 'C' ); + A := B; + B := T; + end Swap; + + function Create return Grinder is + One: Grinder; + begin + F393A00_0.TC_Touch( 'D' ); + F393A00_4.Initialize( F393A00_4.Mill( One ) ); + One.Grind := Fine; + return One; + end Create; + end C393A05_0; + + with Report; + with F393A00_0; + with C393A05_0; + procedure C393A05 is + + package Tracer renames F393A00_0; + package Coffee renames C393A05_0; + use type Coffee.Coarseness; + + Morning : Coffee.Grinder; + Afternoon : Coffee.Grinder; + + Gritty : Coffee.Coarseness; + + procedure Class_Swap( A, B: in out Coffee.Grinder'Class ) is + begin + Coffee.Swap( A, B ); -- dispatch + end Class_Swap; + + begin -- Main test procedure. + + Report.Test ("C393A05", "Check that nonabstract private extensions, " + & "inherited abstract subprograms overridden " + & "in the private part can be dispatched from " + & "outside the package" ); + + Tracer.TC_Validate( "hh", "Declarations" ); + + Morning := Coffee.Create; + Tracer.TC_Validate( "hDa", "Creating Morning Coffee" ); + Gritty := Coffee.Grind( Morning ); + Tracer.TC_Validate( "B", "Finding Morning Grind" ); + + Afternoon := Coffee.Create; + Tracer.TC_Validate( "hDa", "Creating Afternoon Coffee" ); + Coffee.Set_Grind( Afternoon, Coffee.Medium ); + Tracer.TC_Validate( "A", "Setting Afternoon Grind" ); + + Coffee.Swap( Morning, Afternoon ); + Tracer.TC_Validate( "C", "Dispatching Swapping Coffees" ); + + if Gritty /= Coffee.Grind( Afternoon ) + or Coffee.Grind ( Afternoon ) /= Coffee.Fine then + Report.Failed ("Result of Swap"); + end if; + Tracer.TC_Validate( "BB", "Finding Afternoon Grind" ); + + Sunset: declare + Evening : Coffee.Grinder'Class := Coffee.Create; + begin + Tracer.TC_Validate( "hDa", "Creating Evening Coffee" ); + + Coffee.Set_Grind( Evening, Coffee.Espresso ); + Tracer.TC_Validate( "A", "Setting Evening Grind" ); + + Morning := Coffee.Grinder( Evening ); + Class_Swap( Morning, Evening ); + Tracer.TC_Validate( "C", "Swapping Coffees" ); + if Coffee.Grind( Morning ) /= Coffee.Espresso then + Report.Failed ("Result of Assignment"); + end if; + end Sunset; + + Report.Result; + + end C393A05; + + + diff --git a/gcc-4.9/gcc/testsuite/ada/acats/tests/c3/c393a06.a b/gcc-4.9/gcc/testsuite/ada/acats/tests/c3/c393a06.a new file mode 100644 index 000000000..c257d5fa0 --- /dev/null +++ b/gcc-4.9/gcc/testsuite/ada/acats/tests/c3/c393a06.a @@ -0,0 +1,201 @@ +-- C393A06.A +-- +-- Grant of Unlimited Rights +-- +-- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687, +-- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained +-- unlimited rights in the software and documentation contained herein. +-- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making +-- this public release, the Government intends to confer upon all +-- recipients unlimited rights equal to those held by the Government. +-- These rights include rights to use, duplicate, release or disclose the +-- released technical data and computer software in whole or in part, in +-- any manner and for any purpose whatsoever, and to have or permit others +-- to do so. +-- +-- DISCLAIMER +-- +-- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR +-- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED +-- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE +-- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE +-- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A +-- PARTICULAR PURPOSE OF SAID MATERIAL. +--* +-- +-- OBJECTIVE: +-- Check that a type that inherits abstract operations but +-- overrides each of these operations is not required to be +-- abstract, and that objects of the type and its class-wide type +-- may be declared and passed in calls to the overriding +-- subprograms. +-- +-- TEST DESCRIPTION: +-- This test derives a type from the root abstract type available +-- in foundation F393A00. It declares subprograms as required by +-- the language to override the abstract subprograms, allowing the +-- derived type itself to be not abstract. It also declares +-- operations on the new type, as well as on the associated class- +-- wide type. The main program then uses two objects of the type +-- and two objects of the class-wide type as parameters for each of +-- the subprograms. Correct execution is determined by path +-- analysis and value checking. +-- +-- TEST FILES: +-- The following files comprise this test: +-- +-- F393A00.A (foundation code) +-- C393A06.A +-- +-- +-- CHANGE HISTORY: +-- 06 Dec 94 SAIC ACVC 2.0 +-- 19 Dec 94 SAIC Removed RM references from objective text. +-- +--! + + with F393A00_1; + package C393A06_0 is + type Organism is new F393A00_1.Object with private; + type Kingdoms is ( Animal, Vegetable, Unspecified ); + + procedure Swap( A,B: in out Organism ); + function Create return Organism; + + procedure Initialize( The_Entity : in out Organism; + In_The_Kingdom : Kingdoms ); + function Kingdom( Of_The_Entity : Organism ) return Kingdoms; + + procedure TC_Check( An_Entity : Organism'Class; + In_Kingdom : Kingdoms; + Initialized : Boolean ); + + Incompatible : exception; + + private + type Organism is new F393A00_1.Object with + record + In_Kingdom : Kingdoms; + end record; + end C393A06_0; + + with F393A00_0; + package body C393A06_0 is + + procedure Swap( A,B: in out Organism ) is + begin + F393A00_0.TC_Touch( 'A' ); ------------------------------------------- A + if A.In_Kingdom /= B.In_Kingdom then + F393A00_0.TC_Touch( 'X' ); + raise Incompatible; + else + declare + T: constant Organism := A; + begin + A := B; + B := T; + end; + end if; + end Swap; + + function Create return Organism is + Widget : Organism; + begin + F393A00_0.TC_Touch( 'B' ); ------------------------------------------- B + Initialize( Widget ); + Widget.In_Kingdom := Unspecified; + return Widget; + end Create; + + procedure Initialize( The_Entity : in out Organism; + In_The_Kingdom : Kingdoms ) is + begin + F393A00_0.TC_Touch( 'C' ); ------------------------------------------- C + F393A00_1.Initialize( F393A00_1.Object( The_Entity ) ); + The_Entity.In_Kingdom := In_The_Kingdom; + end Initialize; + + function Kingdom( Of_The_Entity : Organism ) return Kingdoms is + begin + F393A00_0.TC_Touch( 'D' ); ------------------------------------------- D + return Of_The_Entity.In_Kingdom; + end Kingdom; + + procedure TC_Check( An_Entity : Organism'Class; + In_Kingdom : Kingdoms; + Initialized : Boolean ) is + begin + if F393A00_1.Initialized( An_Entity ) /= Initialized then + F393A00_0.TC_Touch( '-' ); ------------------------------------------- - + elsif An_Entity.In_Kingdom /= In_Kingdom then + F393A00_0.TC_Touch( '!' ); ------------------------------------------- ! + else + F393A00_0.TC_Touch( '+' ); ------------------------------------------- + + end if; + end TC_Check; + + end C393A06_0; + + with Report; + + with C393A06_0; + with F393A00_0; + with F393A00_1; + procedure C393A06 is + + package Darwin renames C393A06_0; + package Tagger renames F393A00_0; + package Objects renames F393A00_1; + + Lion : Darwin.Organism; + Tigerlily : Darwin.Organism; + Bear : Darwin.Organism'Class := Darwin.Create; + Sunflower : Darwin.Organism'Class := Darwin.Create; + + use type Darwin.Kingdoms; + + begin -- Main test procedure. + + Report.Test ("C393A06", "Check that a type that inherits abstract " + & "operations but overrides each of these " + & "operations is not required to be abstract. " + & "Check that objects of the type and its " + & "class-wide type may be declared and passed " + & "in calls to the overriding subprograms" ); + + Tagger.TC_Validate( "BaBa", "Declaration Initializations" ); + + Darwin.Initialize( Lion, Darwin.Animal ); + Darwin.Initialize( Tigerlily, Darwin.Vegetable ); + Darwin.Initialize( Bear, Darwin.Animal ); + Darwin.Initialize( Sunflower, Darwin.Vegetable ); + + Tagger.TC_Validate( "CaCaCaCa", "Initialization sequence" ); + + Oh_My: begin + Darwin.Swap( Lion, Darwin.Organism( Bear ) ); + Darwin.Swap( Lion, Tigerlily ); + Report.Failed("Exception not raised"); + exception + when Darwin.Incompatible => null; + end Oh_My; + + Tagger.TC_Validate( "AAX", "Swap sequence" ); + + if Darwin.Kingdom( Darwin.Create ) = Darwin.Unspecified then + Darwin.Swap( Sunflower, Darwin.Organism'Class( Tigerlily ) ); + end if; + + Tagger.TC_Validate( "BaDA", "Vegetable swap sequence" ); + + Darwin.TC_Check( Lion, Darwin.Animal, True ); + Darwin.TC_Check( Tigerlily, Darwin.Vegetable, True ); + Darwin.TC_Check( Bear, Darwin.Animal, True ); + Darwin.TC_Check( Sunflower, Darwin.Vegetable, True ); + + Tagger.TC_Validate( "b+b+b+b+", "Final sequence" ); + + Report.Result; + + end C393A06; + diff --git a/gcc-4.9/gcc/testsuite/ada/acats/tests/c3/c393b12.a b/gcc-4.9/gcc/testsuite/ada/acats/tests/c3/c393b12.a new file mode 100644 index 000000000..5d1b46daa --- /dev/null +++ b/gcc-4.9/gcc/testsuite/ada/acats/tests/c3/c393b12.a @@ -0,0 +1,131 @@ +-- C393B12.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. +--* +-- +-- TEST OBJECTIVE: +-- Check that an extended type can be derived in the specification of a +-- generic package when the parent is an abstract type in a library +-- package. +-- +-- TEST DESCRIPTION: +-- Extend an abstract type in the visible part of a generic package. +-- Make all of the procedures which override abstract procedures +-- available as part of the generic interface. Instantiate the generic. +-- +-- TEST FILES: +-- This test depends on the following foundation code: +-- +-- F393B00.A Package Alert_Foundation +-- +-- +-- CHANGE HISTORY: +-- 06 Dec 94 SAIC ACVC 2.0 +-- 14 Oct 95 SAIC Update and repair for ACVC 2.0.1 +-- 27 Feb 97 PWB.CTA Add pragma Elaborate for C393B12_0. +--! + +----------------------------------------------------------------- C393B12_0 + +with F393B00; + -- Alert_Foundation +generic + type Generic_Status_Enum is (<>); + +package C393B12_0 is + -- Alert_Functions + + type Generic_Alert_Type is new F393B00.Alert with record + Status : Generic_Status_Enum := Generic_Status_Enum'First; + end record; + -- extension of an abstract type + + procedure Handle (GA : in out Generic_Alert_Type); + -- override of abstract procedure + + function Query_Status (GA : Generic_Alert_Type) + return Generic_Status_Enum; -- new primitive operation for + -- Generic_Alert_Type +end C393B12_0; + -- Alert_Functions + +-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- + +package body C393B12_0 is + -- Alert_Functions + + procedure Handle (GA : in out Generic_Alert_Type) is + begin + GA.Status := Generic_Status_Enum'Last; + end Handle; + + function Query_Status (GA : Generic_Alert_Type) + return Generic_Status_Enum is + begin + return GA.Status; + end Query_Status; + +end C393B12_0; + +----------------------------------------------------------------- C393B12_1 + +package C393B12_1 is + type Status is (Low, Medium, High); +end C393B12_1; + +------------------------------------------------------- C393B12_1.C393B12_2 + +with C393B12_0; +pragma Elaborate (C393B12_0); +package C393B12_1.C393B12_2 is new C393B12_0 + -- Alert_Functions + (Generic_Status_Enum => Status); + +------------------------------------------------------------------- C393B12 + +with C393B12_1.C393B12_2; +with Report; +procedure C393B12 is + + use type C393B12_1.Status; + + package Alt_Alert renames C393B12_1.C393B12_2; + + GA : Alt_Alert.Generic_Alert_Type; + +begin + Report.Test ("C393B12", "Check that an extended type can be derived " & + "from an abstract type"); + + if Alt_Alert.Query_Status (GA) /= C393B12_1.Low then + Report.Failed ("Wrong initialization"); + end if; + + Alt_Alert.Handle (GA); + if Alt_Alert.Query_Status (GA) /= C393B12_1.High then + Report.Failed ("Wrong results from Handle"); + end if; + + Report.Result; + +end C393B12; diff --git a/gcc-4.9/gcc/testsuite/ada/acats/tests/c3/c393b13.a b/gcc-4.9/gcc/testsuite/ada/acats/tests/c3/c393b13.a new file mode 100644 index 000000000..c533badbe --- /dev/null +++ b/gcc-4.9/gcc/testsuite/ada/acats/tests/c3/c393b13.a @@ -0,0 +1,105 @@ +-- C393B13.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. +--* +-- +-- TEST OBJECTIVE: +-- Check that an extended type can be derived from an abstract type +-- when that derivation is declared in a child package. +-- +-- TEST DESCRIPTION: +-- Add a visible child to Alert_Foundation. Using the abstract type +-- Alert as parent, declare an extended type with discriminant and new +-- record components. Override the Handle procedure. +-- +-- TEST FILES: +-- This test depends on the following foundation code: +-- +-- F393B00.A Package Alert_Foundation +-- +-- +-- CHANGE HISTORY: +-- 06 Dec 94 SAIC ACVC 2.0 +-- 15 Oct 95 SAIC Fixed bugs for ACVC 2.0.1 +-- +--! + +package F393B00.C393B13_0 is + -- Alert_Foundation.Public_Child + + subtype Msg_Length_Range is integer range 0 .. 240; + Max_Msg_Length : constant Msg_Length_Range := 80; + Message : String := "Test Passed"; + + type Child_Alert (Length : Msg_Length_Range) + is new Alert with record -- abstract type is in parent package + Times_Handled : Natural := 0; + Msg : String (1..Length); + end record; + + procedure Handle (CA : in out Child_Alert); -- required override + +end F393B00.C393B13_0; + -- Alert_Foundation.Public_Child; + +--=======================================================================-- + +package body F393B00.C393B13_0 is + -- Alert_Foundation.Public_Child + + procedure Handle (CA : in out Child_Alert) is + begin + CA.Msg(1..Message'Length) := Message; + CA.Times_Handled := CA.Times_Handled + 1; + end; + +end F393B00.C393B13_0; + -- Alert_Foundation.Public_Child + +--=======================================================================-- + +with Report; +with F393B00.C393B13_0; + -- Alert_foundation.Public_Child; +procedure C393B13 is + package Child renames F393B00.C393B13_0; + CA : Child.Child_Alert(Child.Message'Length); + +begin + + Report.Test ("C393B13", "Check that an extended type can be derived " & + "from an abstract type"); + + if CA.Times_Handled /= 0 then + Report.Failed ("Wrong initialization"); + end if; + + Child.Handle (CA); + if (CA.Times_Handled /= 1) + or (CA.Msg /= Child.Message) then + Report.Failed ("Wrong results from Handle"); + end if; + + Report.Result; + +end C393B13; diff --git a/gcc-4.9/gcc/testsuite/ada/acats/tests/c3/c393b14.a b/gcc-4.9/gcc/testsuite/ada/acats/tests/c3/c393b14.a new file mode 100644 index 000000000..f100377aa --- /dev/null +++ b/gcc-4.9/gcc/testsuite/ada/acats/tests/c3/c393b14.a @@ -0,0 +1,147 @@ +-- C393B14.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. +--* +-- +-- TEST OBJECTIVE: +-- Check that an extended type can be derived in a private child package +-- from an abstract type defined in a library package. +-- +-- TEST DESCRIPTION: +-- Add a private child package to Alert_Foundation. Using Private_Alert +-- as parent type, declare an extended type adding a new record component. +-- Override procedure Handle. Declare an object of the new type in the +-- child specification. Use type definitions from the private part of the +-- parent in the body of the child. +-- +-- TEST FILES: +-- This test depends on the following foundation code: +-- +-- F393B00.A Package Alert_Foundation +-- +-- +-- CHANGE HISTORY: +-- 06 Dec 94 SAIC ACVC 2.0 +-- +--! + +private package F393B00.C393B14_0 is + -- Alert_Foundation.Private_Child + + type Implementation_Specific_Alert_Type is new Private_Alert with record + New_Private_Field : Implementation_Detail + := Implementation_Detail'Last; + end record; + + procedure Handle (PA : in out Implementation_Specific_Alert_Type); + -- overrides abstract Handle, as required + PA : Implementation_Specific_Alert_Type; + +end F393B00.C393B14_0; + -- Alert_Foundation.Private_Child + +--=======================================================================-- + +package body F393B00.C393B14_0 is + -- Alert_Foundation.Private_Child + + procedure Handle (PA : in out Implementation_Specific_Alert_Type) is + begin + PA.Private_Field := 1; + PA.New_Private_Field := PA.Private_Field + 1; + end; + +end F393B00.C393B14_0; + -- Alert_Foundation.Private_Child + +--=======================================================================-- + +package F393B00.C393B14_1 is + -- Alert_Foundation.Public_Child + + type Timing is (Before, After); + procedure Init; + procedure Modify; + function Check_Before return Boolean; + function Check_After return Boolean; + +end F393B00.C393B14_1; + -- Alert_Foundation.Public_Child + +--=======================================================================-- + +with F393B00.C393B14_0; -- private sibling is visible in the + -- Alert_Foundation.Private_Child -- body of a public sibling +package body F393B00.C393B14_1 is + -- Alert_Foundation.Public_Child + package Priv renames F393B00.C393B14_0; + + procedure Init is + begin + Priv.PA.Private_Field := 5; + Priv.PA.New_Private_Field := 10; + end Init; + + procedure Modify is + begin + Priv.Handle (Priv.PA); + end Modify; + + function Check_Before return Boolean is + begin + return ((Priv.PA.Private_Field = 5) + and (Priv.PA.New_Private_Field =10)); + end Check_Before; + + function Check_After return Boolean is + begin + return ((Priv.PA.Private_Field = 1) + and (Priv.PA.New_Private_Field = 2)); + end Check_After; + +end F393B00.C393B14_1; + -- Alert_Foundation.Public_Child + +--=======================================================================-- + +with Report; +with F393B00.C393B14_1; +procedure C393B14 is + -- Alert_Foundation.Public_Child; + +begin + Report.Test ("C393B14", "Check that an extended type can be derived " & + "from an abstract type"); + + F393B00.C393B14_1.Init; + if not F393B00.C393B14_1.Check_Before then + Report.Failed ("Wrong initialization"); + end if; + + F393B00.C393B14_1.Modify; + if not F393B00.C393B14_1.Check_After then + Report.Failed ("Wrong results from Handle"); + end if; + + Report.Result; +end C393B14; diff --git a/gcc-4.9/gcc/testsuite/ada/acats/tests/c3/c3a0001.a b/gcc-4.9/gcc/testsuite/ada/acats/tests/c3/c3a0001.a new file mode 100644 index 000000000..f8a0681e7 --- /dev/null +++ b/gcc-4.9/gcc/testsuite/ada/acats/tests/c3/c3a0001.a @@ -0,0 +1,138 @@ +-- C3A0001.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 access to subprogram type can be used to select and +-- invoke functions with appropriate arguments dynamically. +-- +-- TEST DESCRIPTION: +-- Declare an access to function type in a package specification. +-- Declare three different sine functions that can be referred to by +-- the access to function type. +-- +-- In the main program, call each function indirectly by dereferencing +-- the access value. +-- +-- +-- CHANGE HISTORY: +-- 06 Dec 94 SAIC ACVC 2.0 +-- +--! + +package C3A0001_0 is + + TC_Call_Tag : Natural := 0; + + -- Type accesses to any sine function + type Sine_Function_Ptr is access function + (Angle : in Float) return Float; + +-- Three 'Sine' functions that model an application situation in which +-- one function might be chosen when speed is important, another (using +-- a different algorithm) might be chosen when accuracy is important, +-- and so on. + + function Sine_Calc_Fast (Angle : in Float) return Float; + + function Sine_Calc_Acc (Angle : in Float) return Float; + + function Sine_Calc_Table (Angle : in Float) return Float; + +end C3A0001_0; + + +----------------------------------------------------------------------------- + + +package body C3A0001_0 is + + function Sine_Calc_Fast (Angle : in Float) return Float is + begin + TC_Call_Tag := 1; + return 1.0; + end Sine_Calc_Fast; + + + function Sine_Calc_Acc (Angle : in Float) return Float is + begin + TC_Call_Tag := 2; + return 0.0; + end Sine_Calc_Acc; + + + function Sine_Calc_Table (Angle : in Float) return Float is + begin + TC_Call_Tag := 3; + return -1.0; + end Sine_Calc_Table; + +end C3A0001_0; + +----------------------------------------------------------------------------- + +with Report; +with C3A0001_0; + +procedure C3A0001 is + + Sine_Access : C3A0001_0.Sine_Function_Ptr; + X, Theta : Float := 0.0; + +begin + + Report.Test ("C3A0001", "Check that access to subprogram can be " & + "used to select and invoke an operation with " & + "appropriate arguments dynamically"); + + Sine_Access := C3A0001_0.Sine_Calc_Fast'Access; + + -- Invoking Sine function designated by access value + X := Sine_Access(Theta); + + If C3A0001_0.TC_Call_Tag /= 1 then + Report.Failed ("Incorrect Sine_Calc_Fast result"); + end if; + + Sine_Access := C3A0001_0.Sine_Calc_Acc'Access; + + -- Invoking Sine function designated by access value + X := Sine_Access(Theta); + + If C3A0001_0.TC_Call_Tag /= 2 then + Report.Failed ("Incorrect Sine_Calc_Acc result"); + end if; + + Sine_Access := C3A0001_0.Sine_Calc_Table'Access; + + -- Invoking Sine function designated by access value + X := Sine_Access(Theta); + + If C3A0001_0.TC_Call_Tag /= 3 then + Report.Failed ("Incorrect Sine_Calc_Table result"); + end if; + + Report.Result; + +end C3A0001; diff --git a/gcc-4.9/gcc/testsuite/ada/acats/tests/c3/c3a0002.a b/gcc-4.9/gcc/testsuite/ada/acats/tests/c3/c3a0002.a new file mode 100644 index 000000000..5c05d43fb --- /dev/null +++ b/gcc-4.9/gcc/testsuite/ada/acats/tests/c3/c3a0002.a @@ -0,0 +1,142 @@ +-- C3A0002.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 access to subprogram type can be used to select and +-- invoke procedures with appropriate arguments dynamically. +-- +-- TEST DESCRIPTION: +-- Declare an access to procedure type in a package specification. +-- Declare three different log procedures that can be referred to by +-- the access to procedure type. +-- +-- In the main program, call each procedure indirectly by dereferencing +-- the access value. +-- +-- +-- CHANGE HISTORY: +-- 06 Dec 94 SAIC ACVC 2.0 +-- 05 APR 96 SAIC RM reference change for 2.1 +-- +-- +--! + + +package C3A0002_0 is + + TC_Call_Tag : Natural := 0; + + Return_Num : Float := 0.0; + + -- Type accesses to any log procedure + type Log_Procedure_Ptr is access procedure + (Angle : in Float); + + procedure Log_Calc_Fast (Angle : in Float); + + procedure Log_Calc_Acc (Angle : in Float); + + procedure Log_Calc_Table (Angle : in Float); + +end C3A0002_0; + + +----------------------------------------------------------------------------- + + +package body C3A0002_0 is + + procedure Log_Calc_Fast (Angle : in Float) is + begin + TC_Call_Tag := 1; + Return_Num := Angle; + end Log_Calc_Fast; + + + procedure Log_Calc_Acc (Angle : in Float) is + begin + TC_Call_Tag := 2; + Return_Num := Angle; + end Log_Calc_Acc; + + + procedure Log_Calc_Table (Angle : in Float) is + begin + TC_Call_Tag := 3; + Return_Num := Angle; + end Log_Calc_Table; + +end C3A0002_0; + +----------------------------------------------------------------------------- + +with Report; +with C3A0002_0; + +procedure C3A0002 is + + Log_Access : C3A0002_0.Log_Procedure_Ptr; + Theta : Float := 0.0; + +begin + + Report.Test ("C3A0002", "Check that access to subprogram type can be " + & "used to select and invoke procedures with " + & "appropriate arguments dynamically" ); + + Log_Access := C3A0002_0.Log_Calc_Fast'Access; + + -- Invoking Log procedure designated by access value + Log_Access (Theta); + + If C3A0002_0.TC_Call_Tag /= 1 or C3A0002_0.Return_Num /= 0.0 then + Report.Failed ("Incorrect Log_Calc_Fast result"); + end if; + + Theta := 1.0; + + Log_Access := C3A0002_0.Log_Calc_Acc'Access; + + -- Invoking Log procedure designated by access value + Log_Access (Theta); + + If C3A0002_0.TC_Call_Tag /= 2 or C3A0002_0.Return_Num /= 1.0 then + Report.Failed ("Incorrect Log_Calc_Acc result"); + end if; + + Theta := -1.0; + + Log_Access := C3A0002_0.Log_Calc_Table'Access; + + -- Invoking Log procedure designated by access value + Log_Access (Theta); + + If C3A0002_0.TC_Call_Tag /= 3 or C3A0002_0.Return_Num /= -1.0 then + Report.Failed ("Incorrect Log_Calc_Table result"); + end if; + + Report.Result; + +end C3A0002; diff --git a/gcc-4.9/gcc/testsuite/ada/acats/tests/c3/c3a0003.a b/gcc-4.9/gcc/testsuite/ada/acats/tests/c3/c3a0003.a new file mode 100644 index 000000000..4f9fdbe29 --- /dev/null +++ b/gcc-4.9/gcc/testsuite/ada/acats/tests/c3/c3a0003.a @@ -0,0 +1,144 @@ +-- C3A0003.A +-- +-- Grant of Unlimited Rights +-- +-- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687, +-- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained +-- unlimited rights in the software and documentation contained herein. +-- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making +-- this public release, the Government intends to confer upon all +-- recipients unlimited rights equal to those held by the Government. +-- These rights include rights to use, duplicate, release or disclose the +-- released technical data and computer software in whole or in part, in +-- any manner and for any purpose whatsoever, and to have or permit others +-- to do so. +-- +-- DISCLAIMER +-- +-- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR +-- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED +-- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE +-- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE +-- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A +-- PARTICULAR PURPOSE OF SAID MATERIAL. +--* +-- +-- OBJECTIVE: +-- Check that a function in a generic instance can be called using +-- an access-to-subprogram value. +-- +-- TEST DESCRIPTION: +-- Declare a numeric type in the visible part of a generic package. +-- Declare an access to function type. Declare three different sine +-- functions that can be referred to by the access to function type. +-- +-- In the main program, instantiate the generic. Call each function +-- indirectly by dereferencing the access value. +-- +-- +-- CHANGE HISTORY: +-- 06 Dec 94 SAIC ACVC 2.0 +-- +--! + +generic + type Real_Num is digits <>; + +package C3A0003_0 is + + TC_Call_Tag : Natural := 0; + + -- Type accesses to any sine function + type Sine_Function_Ptr is access function + (Angle : in Real_Num) return Real_Num; + + function Sine_Calc_Fast (Angle : in Real_Num) return Real_Num; + + function Sine_Calc_Acc (Angle : in Real_Num) return Real_Num; + + function Sine_Calc_Table (Angle : in Real_Num) return Real_Num; + +end C3A0003_0; + + +----------------------------------------------------------------------------- + + +package body C3A0003_0 is + + function Sine_Calc_Fast (Angle : in Real_Num) return Real_Num is + Sine_Num : Real_Num := 1.0; + begin + TC_Call_Tag := 1; + return Sine_Num; + end Sine_Calc_Fast; + + + function Sine_Calc_Acc (Angle : in Real_Num) return Real_Num is + Sine_Num : Real_Num := 0.0; + begin + TC_Call_Tag := 2; + return Sine_Num; + end Sine_Calc_Acc; + + + function Sine_Calc_Table (Angle : in Real_Num) return Real_Num is + Sine_Num : Real_Num := -1.0; + begin + TC_Call_Tag := 3; + return Sine_Num; + end Sine_Calc_Table; + +end C3A0003_0; + +----------------------------------------------------------------------------- + +with Report; +with C3A0003_0; + +procedure C3A0003 is + + type Real is digits 5; + + Subtype Trig_Float is Real range -1.0 .. 1.0; + + package Trig is new C3A0003_0 (Real_Num => Trig_Float); + + Sine_Access : Trig.Sine_Function_Ptr; + X, Theta : Trig_Float := 0.0; + +begin + + Report.Test ("C3A0003", "Check that a function in a generic instance can " + & "be called using an access-to-subprogram value"); + + Sine_Access := Trig.Sine_Calc_Fast'Access; + + -- Invoking Sine function designated by access value + X := Sine_Access.all(Theta); + + If Trig.TC_Call_Tag /= 1 then + Report.Failed ("Incorrect Sine_Calc_Fast result"); + end if; + + Sine_Access := Trig.Sine_Calc_Acc'Access; + + -- Invoking Sine function designated by access value + X := Sine_Access.all(Theta); + + If Trig.TC_Call_Tag /= 2 then + Report.Failed ("Incorrect Sine_Calc_Acc result"); + end if; + + Sine_Access := Trig.Sine_Calc_Table'Access; + + -- Invoking Sine function designated by access value + X := Sine_Access.all(Theta); + + If Trig.TC_Call_Tag /= 3 then + Report.Failed ("Incorrect Sine_Calc_Table result"); + end if; + + Report.Result; + +end C3A0003; diff --git a/gcc-4.9/gcc/testsuite/ada/acats/tests/c3/c3a0004.a b/gcc-4.9/gcc/testsuite/ada/acats/tests/c3/c3a0004.a new file mode 100644 index 000000000..2557546c2 --- /dev/null +++ b/gcc-4.9/gcc/testsuite/ada/acats/tests/c3/c3a0004.a @@ -0,0 +1,115 @@ +-- C3A0004.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 access to subprogram may be stored within array + -- objects, and that the access to subprogram can subsequently + -- be called. + -- + -- TEST DESCRIPTION: + -- Declare an access to procedure type in a package specification. + -- Declare an array of the access type. Declare three different + -- procedures that can be referred to by the access to procedure type. + -- + -- In the main program, build the array by dereferencing the access + -- value. + -- + -- +-- CHANGE HISTORY: +-- 06 Dec 94 SAIC ACVC 2.0 +-- + --! + + with Report; + + procedure C3A0004 is + + Left_Turn : Integer := 1; + + Right_Turn : Integer := 1; + + Center_Turn : Integer := 1; + + -- Type accesses to any procedure + type Action_Ptr is access procedure; + + -- Array of access to procedure + type Action_Array is array (Integer range <>) of Action_Ptr; + + + procedure Rotate_Left is + begin + Left_Turn := 2; + end Rotate_Left; + + + procedure Rotate_Right is + begin + Right_Turn := 3; + end Rotate_Right; + + + procedure Center is + begin + Center_Turn := 0; + end Center; + + + begin + + Report.Test ("C3A0004", "Check that access to subprogram may be " + & "stored within data structures, and that the " + & "access to subprogram can subsequently be called"); + + ------------------------------------------------------------------------ + + declare + Total_Actions : constant := 3; + Action_Sequence : Action_Array (1 .. Total_Actions); + + begin + + -- Build the action sequence + Action_Sequence := (Rotate_Left'Access, Center'Access, + Rotate_Right'Access); + + -- Assign actions by invoking subprogram designated by access value + for I in Action_Sequence'Range loop + Action_Sequence(I).all; + end loop; + + If Left_Turn /= 2 or Right_Turn /= 3 + or Center_Turn /= 0 then + Report.Failed ("Incorrect Action sequence result"); + end if; + + end; + + ------------------------------------------------------------------------ + + Report.Result; + + end C3A0004; + diff --git a/gcc-4.9/gcc/testsuite/ada/acats/tests/c3/c3a0005.a b/gcc-4.9/gcc/testsuite/ada/acats/tests/c3/c3a0005.a new file mode 100644 index 000000000..1f2368957 --- /dev/null +++ b/gcc-4.9/gcc/testsuite/ada/acats/tests/c3/c3a0005.a @@ -0,0 +1,147 @@ +-- C3A0005.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 access to subprogram may be stored within record +-- objects, and that the access to subprogram can subsequently +-- be called. +-- +-- TEST DESCRIPTION: +-- Declare an access to procedure type in a package specification. +-- Declare two different procedures that can be referred to by the +-- access to procedure type. Declare a record with the access to +-- procedure type as a component. Use the access to procedure type to +-- initialize the component of a record. +-- +-- In the main program, declare an operation. An access value +-- designating this operation is passed as a parameter to be +-- stored in the record. +-- +-- +-- CHANGE HISTORY: +-- 06 Dec 94 SAIC ACVC 2.0 +-- +--! + +package C3A0005_0 is + + Default_Call : Boolean := False; + + type Button; + + + -- Type accesses to procedures Push and Default_Response + type Button_Response_Ptr is access procedure + (B : access Button); + + procedure Push (B : access Button); + + procedure Set_Response (B : access Button; + R : in Button_Response_Ptr); + + procedure Default_Response (B : access Button); + + Emergency_Call : Boolean := False; + + procedure Emergency (B : access C3A0005_0.Button); + + type Button is + record + Response : Button_Response_Ptr + := Default_Response'Access; + end record; + +end C3A0005_0; + + +----------------------------------------------------------------------------- + +with TCTouch; +package body C3A0005_0 is + + procedure Push (B : access Button) is + begin + TCTouch.Touch( 'P' ); --------------------------------------------- P + -- Invoking subprogram designated by access value + B.Response (B); + end Push; + + + procedure Set_Response (B : access Button; + R : in Button_Response_Ptr) is + begin + TCTouch.Touch( 'S' ); --------------------------------------------- S + -- Set procedure value in record + B.Response := R; + end Set_Response; + + + procedure Default_Response (B : access Button) is + begin + TCTouch.Touch( 'D' ); --------------------------------------------- D + Default_Call := True; + end Default_Response; + + + procedure Emergency (B : access C3A0005_0.Button) is + begin + TCTouch.Touch( 'E' ); --------------------------------------------- E + Emergency_Call := True; + end Emergency; + +end C3A0005_0; + + +----------------------------------------------------------------------------- + +with TCTouch; +with Report; + +with C3A0005_0; + +procedure C3A0005 is + + Big_Red_Button : aliased C3A0005_0.Button; + +begin + + Report.Test ("C3A0005", "Check that access to subprogram may be " + & "stored within data structures, and that the " + & "access to subprogram can subsequently be called"); + + C3A0005_0.Push (Big_Red_Button'Access); + TCTouch.Validate("PD", "Using default value"); + TCTouch.Assert( C3A0005_0.Default_Call, "Default Call" ); + + -- set Emergency value in Button.Response + C3A0005_0.Set_Response(Big_Red_Button'Access, C3A0005_0.Emergency'Access); + + C3A0005_0.Push (Big_Red_Button'Access); + TCTouch.Validate("SPE", "After set to Emergency value"); + TCTouch.Assert( C3A0005_0.Emergency_Call, "Emergency Call"); + + Report.Result; + +end C3A0005; diff --git a/gcc-4.9/gcc/testsuite/ada/acats/tests/c3/c3a0006.a b/gcc-4.9/gcc/testsuite/ada/acats/tests/c3/c3a0006.a new file mode 100644 index 000000000..effab3465 --- /dev/null +++ b/gcc-4.9/gcc/testsuite/ada/acats/tests/c3/c3a0006.a @@ -0,0 +1,163 @@ +-- C3A0006.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 access to subprogram may be stored within data +-- structures, and that the access to subprogram can subsequently +-- be called. +-- +-- TEST DESCRIPTION: +-- Declare an access to function type in a package specification. +-- Declare an array of the access type. Declare three different +-- functions that can be referred to by the access to function type. +-- +-- In the main program, declare a key function that builds the array +-- by calling each function indirectly through the access value. +-- +-- +-- CHANGE HISTORY: +-- 06 Dec 94 SAIC ACVC 2.0 +-- +--! + + +package C3A0006_0 is + + TC_Sine_Call : Integer := 0; + TC_Cos_Call : Integer := 0; + TC_Tan_Call : Integer := 0; + + Sine_Value : Float := 4.0; + Cos_Value : Float := 8.0; + Tan_Value : Float := 10.0; + + -- Type accesses to any function + type Trig_Function_Ptr is access function + (Angle : in Float) return Float; + + function Sine (Angle : in Float) return Float; + + function Cos (Angle : in Float) return Float; + + function Tan (Angle : in Float) return Float; + +end C3A0006_0; + + +----------------------------------------------------------------------------- + + +package body C3A0006_0 is + + function Sine (Angle : in Float) return Float is + begin + TC_Sine_Call := TC_Sine_Call + 1; + Sine_Value := Sine_Value + Angle; + return Sine_Value; + end Sine; + + + function Cos (Angle: in Float) return Float is + begin + TC_Cos_Call := TC_Cos_Call + 1; + Cos_Value := Cos_Value - Angle; + return Cos_Value; + end Cos; + + + function Tan (Angle : in Float) return Float is + begin + TC_Tan_Call := TC_Tan_Call + 1; + Tan_Value := (Tan_Value + (Tan_Value * Angle)); + return Tan_Value; + end Tan; + + +end C3A0006_0; + +----------------------------------------------------------------------------- + + +with Report; + +with C3A0006_0; + +procedure C3A0006 is + + Trig_Value, Theta : Float := 0.0; + + Total_Routines : constant := 3; + + Sine_Total : constant := 7.0; + Cos_Total : constant := 5.0; + Tan_Total : constant := 75.0; + + Trig_Table : array (1 .. Total_Routines) of C3A0006_0.Trig_Function_Ptr; + + + -- Key function to build the table + function Call_Trig_Func (Func : C3A0006_0.Trig_Function_Ptr; + Operand : Float) return Float is + begin + return (Func(Operand)); + end Call_Trig_Func; + + +begin + + Report.Test ("C3A0006", "Check that access to subprogram may be " & + "stored within data structures, and that the access " & + "to subprogram can subsequently be called"); + + Trig_Table := (C3A0006_0.Sine'Access, C3A0006_0.Cos'Access, + C3A0006_0.Tan'Access); + + -- increase the value of Theta to build the table + for I in 1 .. Total_Routines loop + Theta := Theta + 0.5; + for J in 1 .. Total_Routines loop + Trig_Value := Call_Trig_Func (Trig_Table(J), Theta); + end loop; + end loop; + + if C3A0006_0.TC_Sine_Call /= Total_Routines + or C3A0006_0.TC_Cos_Call /= Total_Routines + or C3A0006_0.TC_Tan_Call /= Total_Routines then + Report.Failed ("Incorrect subprograms result"); + end if; + + if C3A0006_0.Sine_Value /= Sine_Total + or C3A0006_0.Cos_Value /= Cos_Total + or C3A0006_0.Tan_Value /= Tan_Total then + Report.Failed ("Incorrect values returned from subprograms"); + end if; + + if Trig_Value /= Tan_Total then + Report.Failed ("Incorrect call order."); + end if; + + Report.Result; + +end C3A0006; diff --git a/gcc-4.9/gcc/testsuite/ada/acats/tests/c3/c3a0007.a b/gcc-4.9/gcc/testsuite/ada/acats/tests/c3/c3a0007.a new file mode 100644 index 000000000..ff18d2f9e --- /dev/null +++ b/gcc-4.9/gcc/testsuite/ada/acats/tests/c3/c3a0007.a @@ -0,0 +1,234 @@ +-- C3A0007.A +-- +-- Grant of Unlimited Rights +-- +-- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687, +-- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained +-- unlimited rights in the software and documentation contained herein. +-- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making +-- this public release, the Government intends to confer upon all +-- recipients unlimited rights equal to those held by the Government. +-- These rights include rights to use, duplicate, release or disclose the +-- released technical data and computer software in whole or in part, in +-- any manner and for any purpose whatsoever, and to have or permit others +-- to do so. +-- +-- DISCLAIMER +-- +-- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR +-- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED +-- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE +-- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE +-- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A +-- PARTICULAR PURPOSE OF SAID MATERIAL. +--* +-- +-- OBJECTIVE: +-- Check that a call to a subprogram via an access-to-subprogram value +-- stored in a data structure will correctly dispatch according to the +-- tag of the class-wide parameter passed via that call. +-- +-- TEST DESCRIPTION: +-- Declare an access to procedure type in a package specification. +-- Declare a root tagged type with the access to procedure type as a +-- component. Declare three primitive procedures for the type that +-- can be referred to by the access to procedure type. Use the access +-- to procedure type to initialize the component of a record. +-- +-- Extend the root type with a record extension in another package +-- specification. Declare a new primitive procedure for the extension +-- (in addition to its three inherited subprograms). +-- +-- In the main program, declare an operation for the root tagged type +-- which can be passed as an access value to change the initial value +-- of the component. Call the inherited operation indirectly by +-- dereferencing the access value to check on the initial value of the +-- extension. Call inherited operations indirectly by dereferencing +-- the access value to replace the initial value. Call the primitive +-- procedure indirectly by dereferencing the access value to modify the +-- extension. +-- +-- type Button +-- procedure Push(Button) +-- procedure Set_Response(Button,Button_Response_Ptr) +-- procedure Default_Response(Button) +-- +-- type Priority_Button (new Button) +-- procedures Push, Set_Response inherited +-- procedure Default_Response +-- procedure Set_Priority +-- +-- +-- CHANGE HISTORY: +-- 06 Dec 94 SAIC ACVC 2.0 +-- +--! + +package C3A0007_0 is + + Default_Call : Boolean := False; + + type Button is tagged private; + + type Button_Response_Ptr is access procedure + (B : in out Button'Class); + + procedure Push (B : in out Button); -- to be inherited + + procedure Set_Response (B : in out Button; -- to be inherited + R : in Button_Response_Ptr); + + procedure Response (B : in out Button); -- to be inherited + +private + procedure Default_Response(B: in out Button'Class); + type Button is tagged -- root tagged type + record + Action : Button_Response_Ptr + := Default_Response'Access; + end record; +end C3A0007_0; + +with C3A0007_0; +package C3A0007_1 is + + type Priority_Button is new C3A0007_0.Button + with record + Priority : Integer := 0; + end record; + + -- Inherits procedure Push from Button + -- Inherits procedure Set_Response from Button + + -- Override procedure Response from Button + procedure Response (B : in out Priority_Button); + + -- Primitive operation of the extension + procedure Set_Priority (B : in out Priority_Button); + +end C3A0007_1; + +with C3A0007_0; +package C3A0007_2 is + + Emergency_Call : Boolean := False; + + procedure Emergency (B : in out C3A0007_0.Button'Class); +end C3A0007_2; + +----------------------------------------------------------------------------- + +with TCTouch; +package body C3A0007_0 is + + procedure Push (B : in out Button) is + begin + TCTouch.Touch( 'P' ); --------------------------------------------- P + -- Invoking subprogram designated by access value + B.Action (B); + end Push; + + + procedure Set_Response (B : in out Button; + R : in Button_Response_Ptr) is + begin + TCTouch.Touch( 'S' ); --------------------------------------------- S + -- Set procedure value in record + B.Action := R; + end Set_Response; + + + procedure Response (B : in out Button) is + begin + TCTouch.Touch( 'D' ); --------------------------------------------- D + Default_Call := True; + end Response; + + procedure Default_Response (B : in out Button'Class) is + begin + TCTouch.Touch( 'C' ); --------------------------------------------- C + Response(B); + end Default_Response; + +end C3A0007_0; + +with TCTouch; +package body C3A0007_1 is + + procedure Set_Priority (B : in out Priority_Button) is + begin + TCTouch.Touch( 's' ); --------------------------------------------- s + B.Priority := 1; + end Set_Priority; + + procedure Response (B : in out Priority_Button) is + begin + TCTouch.Touch( 'd' ); --------------------------------------------- d + end Response; + +end C3A0007_1; + +with TCTouch; +package body C3A0007_2 is + procedure Emergency (B : in out C3A0007_0.Button'Class) is + begin + TCTouch.Touch( 'E' ); ------------------------------------------- E + Emergency_Call := True; + end Emergency; +end C3A0007_2; + +----------------------------------------------------------------------------- + +with Report; +with TCTouch; + +with C3A0007_0; +with C3A0007_1; +with C3A0007_2; +procedure C3A0007 is + + Pink_Button : C3A0007_0.Button; + Green_Button : C3A0007_1.Priority_Button; + +begin + + Report.Test ("C3A0007", "Check that a call to a subprogram via an " + & "access-to-subprogram value stored in a data " + & "structure will correctly dispatch according to " + & "the tag of the class-wide parameter passed " + & "via that call" ); + + -- Call inherited operation Push to set Default_Response value + -- in the extension. + + C3A0007_1.Push (Green_Button); + TCTouch.Validate("PCd", "First Green Button Push"); + + TCTouch.Assert_Not(C3A0007_0.Default_Call, + "Incorrect Green Default_Response"); + + C3A0007_0.Push (Pink_Button); + TCTouch.Validate("PCD", "First Pink Button Push"); + + -- Call inherited operations Set_Response and Push to set + -- Emergency value in the extension. + C3A0007_1.Set_Response (Green_Button, C3A0007_2.Emergency'Access); + C3A0007_1.Push (Green_Button); + TCTouch.Validate("SPE", "Second Green Button Push"); + + TCTouch.Assert(C3A0007_2.Emergency_Call, "Incorrect Green Emergency"); + + C3A0007_0.Set_Response (Pink_Button, C3A0007_2.Emergency'Access); + C3A0007_0.Push (Pink_Button); + TCTouch.Validate("SPE", "Second Pink Button Push"); + + -- Call primitive operation to set priority value + -- in the extension. + C3A0007_1.Set_Priority (Green_Button); + TCTouch.Validate("s", "Green Button Priority"); + + TCTouch.Assert(Green_Button.Priority = 1, "Incorrect Set_Priority"); + + Report.Result; + +end C3A0007; diff --git a/gcc-4.9/gcc/testsuite/ada/acats/tests/c3/c3a0008.a b/gcc-4.9/gcc/testsuite/ada/acats/tests/c3/c3a0008.a new file mode 100644 index 000000000..6cd9ce3dd --- /dev/null +++ b/gcc-4.9/gcc/testsuite/ada/acats/tests/c3/c3a0008.a @@ -0,0 +1,150 @@ +-- C3A0008.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 subprogram references may be passed as parameters using +-- access-to-subprogram types. Check that the passed subprograms may +-- be invoked from within the called subprogram. +-- +-- TEST DESCRIPTION: +-- Declare an access to function type in a package specification. +-- Declare three different trig functions that can be referred to by +-- the access to function type. +-- +-- In the main program, call each function indirectly by passing the +-- access to subprogram value as parameter. +-- +-- +-- CHANGE HISTORY: +-- 06 Dec 94 SAIC ACVC 2.0 +-- +--! + + +package Integrate_Lookup is + + TC_Log_Call : Boolean := False; + + TC_Cos_Call : Boolean := False; + + TC_Sine_Call : Boolean := False; + + -- Type accesses to functions Log, Sine, or Cos + type Integrand_Ptr is access function + (Angle : Float) return Float; + + function Log (Angle : in Float) return Float; + + function Sine (Angle : in Float) return Float; + + function Cos (Angle : in Float) return Float; + + function Integrate (Func : Integrand_Ptr; From, To: Float) + return Float; + +end Integrate_Lookup; + + +----------------------------------------------------------------------------- + + +package body Integrate_Lookup is + + + function Log (Angle : in Float) return Float is + begin + TC_Log_Call := True; + return 0.1; + end Log; + + + function Sine (Angle : in Float) return Float is + begin + TC_Sine_Call := True; + return 0.0; + end Sine; + + + function Cos (Angle : in Float) return Float is + begin + TC_Cos_Call := True; + return 1.0; + end Cos; + + + function Integrate (Func : Integrand_Ptr; From, To: Float) + return Float is + Theta : Float; + begin + -- calls the actual subprogram passed as parameter + Theta := Func (From) + Func (To); + return Theta; + end Integrate; + +end Integrate_Lookup; + + +----------------------------------------------------------------------------- + + +with Report; + +with Integrate_Lookup; + +procedure C3A0008 is + + Area : Float := 0.0; + +begin + + Report.Test ("C3A0008", "Check that subprogram references may be passed " + & "as parameters using access-to-subprogram types. " + & "Check that the passed subprograms may be invoked " + & "from within the called subprogram"); + + Area := Integrate_Lookup.Integrate + (Integrate_Lookup.Log'Access, 1.0, 2.0); + + If not Integrate_Lookup.TC_Log_Call or Area /= 0.2 then + Report.Failed ("Incorrect Log result"); + end if; + + Area := Integrate_Lookup.Integrate + (Integrate_Lookup.Sine'Access, 1.0, 2.0); + + If not Integrate_Lookup.TC_Sine_Call or Area /= 0.0 then + Report.Failed ("Incorrect Sine result"); + end if; + + Area := Integrate_Lookup.Integrate + (Integrate_Lookup.Cos'Access, 1.0, 2.0); + + If not Integrate_Lookup.TC_Cos_Call or Area /= 2.0 then + Report.Failed ("Incorrect Cos result"); + end if; + + Report.Result; + +end C3A0008; diff --git a/gcc-4.9/gcc/testsuite/ada/acats/tests/c3/c3a0009.a b/gcc-4.9/gcc/testsuite/ada/acats/tests/c3/c3a0009.a new file mode 100644 index 000000000..ba3f2f6e1 --- /dev/null +++ b/gcc-4.9/gcc/testsuite/ada/acats/tests/c3/c3a0009.a @@ -0,0 +1,219 @@ +-- C3A0009.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 subprogram references may be passed as parameters using +-- access-to-subprogram types. Check that the passed subprograms may +-- be invoked from within the called subprogram. +-- +-- TEST DESCRIPTION: +-- Declare an access to procedure type in a package specification. +-- Declare a root tagged type with the access to procedure type as a +-- component. Declare three primitive procedures for the type that +-- can be referred to by the access to procedure type. Use the access +-- to procedure type to initialize the component of a record. +-- +-- Extend the root type with a private extension in the same package +-- specification. Declare two new primitive subprograms for the extension +-- (in addition to its three inherited subprograms). +-- +-- In the main program, declare an operation for the root tagged type +-- which can be passed as an access value to change the initial value +-- of the component. Call the inherited operations indirectly by +-- de-referencing the access value to set value in the extension. +-- Call the primitive function to modify the extension by passing +-- the access value designating the primitive procedure as a parameter. +-- +-- +-- CHANGE HISTORY: +-- 06 Dec 94 SAIC ACVC 2.0 +-- +--! + +package C3A0009_0 is -- Push_Buttons + + type Button is tagged private; + + -- Type accesses to procedures Push and Default_Response + type Button_Response_Ptr is access procedure + (B : in out Button); + + procedure Push (B : in out Button); -- to be inherited + + procedure Set_Response (B : in out Button; -- to be inherited + R : in Button_Response_Ptr); + + procedure Default_Response (B : in out Button); -- to be inherited + + type Alert_Button is new Button with private; -- private extension of + -- root tagged type + -- Inherits procedure Push from Button + -- Inherits procedure Set_Response from Button + -- Inherits procedure Default_Response from Button + + procedure Replace_Action( B: in out Alert_Button ); + + -- type accesses to procedure Default_Action + type Button_Action_Ptr is access procedure; + + -- The following function is needed to set value in the + -- extension's private component. + function Alert (B : in Alert_Button) return Button_Action_Ptr; + +private + + type Button is tagged -- root tagged type + record + Response : Button_Response_Ptr + := Default_Response'Access; + end record; + + procedure Default_Action; + + type Alert_Button is new Button with record + Action : Button_Action_Ptr + := Default_Action'Access; + end record; + +end C3A0009_0; + + +----------------------------------------------------------------------------- + + +with TCTouch; +package body C3A0009_0 is + + procedure Push (B : in out Button) is + begin + TCTouch.Touch( 'P' ); --------------------------------------------- P + -- Invoking subprogram designated by access value + B.Response (B); + end Push; + + + procedure Set_Response (B : in out Button; + R : in Button_Response_Ptr) is + begin + TCTouch.Touch( 'S' ); --------------------------------------------- S + -- Set procedure value in record + B.Response := R; + end Set_Response; + + + procedure Default_Response (B : in out Button) is + begin + TCTouch.Touch( 'D' ); --------------------------------------------- D + end Default_Response; + + + procedure Default_Action is + begin + TCTouch.Touch( 'd' ); --------------------------------------------- d + end Default_Action; + + procedure Replacement_Action is + begin + TCTouch.Touch( 'r' ); --------------------------------------------- r + end Replacement_Action; + + procedure Replace_Action( B: in out Alert_Button ) is + begin + TCTouch.Touch( 'R' ); --------------------------------------------- R + B.Action := Replacement_Action'Access; + end Replace_Action; + + function Alert (B : in Alert_Button) return Button_Action_Ptr is + begin + TCTouch.Touch( 'A' ); --------------------------------------------- A + return (B.Action); + end Alert; + +end C3A0009_0; + +----------------------------------------------------------------------------- + +with C3A0009_0; +package C3A0009_1 is -- Emergency_Items + package Push_Buttons renames C3A0009_0; + + procedure Emergency (B : in out Push_Buttons.Button); +end C3A0009_1; + +with TCTouch; +package body C3A0009_1 is -- Emergency_Items + procedure Emergency (B : in out Push_Buttons.Button) is + begin + TCTouch.Touch( 'E' ); ------------------------------------------- E + end Emergency; +end C3A0009_1; +----------------------------------------------------------------------------- + +with Report; + +with C3A0009_0, C3A0009_1; +with TCTouch; +procedure C3A0009 is + + package Push_Buttons renames C3A0009_0; + package Emergency_Items renames C3A0009_1; + + Black_Button : Push_Buttons.Alert_Button; + Alert_Ptr : Push_Buttons.Button_Action_Ptr; + +begin + + Report.Test ("C3A0009", "Check that subprogram references may be passed " + & "as parameters using access-to-subprogram types. " + & "Check that the passed subprograms may be " + & "invoked from within the called subprogram"); + + + Push_Buttons.Push( Black_Button ); + Push_Buttons.Alert( Black_Button ).all; + + TCTouch.Validate( "PDAd", "Default operation set" ); + + -- Call inherited operations Set_Response and Push to set + -- Emergency value in the extension. + Push_Buttons.Set_Response (Black_Button, Emergency_Items.Emergency'Access); + + + Push_Buttons.Push( Black_Button ); + Push_Buttons.Alert( Black_Button ).all; + + TCTouch.Validate( "SPEAd", "Altered Response set" ); + + -- Call primitive operation to set action value in the extension. + Push_Buttons.Replace_Action( Black_Button ); + + + Push_Buttons.Push( Black_Button ); + Push_Buttons.Alert( Black_Button ).all; + + TCTouch.Validate( "RPEAr", "Altered Action set" ); + + Report.Result; +end C3A0009; diff --git a/gcc-4.9/gcc/testsuite/ada/acats/tests/c3/c3a0010.a b/gcc-4.9/gcc/testsuite/ada/acats/tests/c3/c3a0010.a new file mode 100644 index 000000000..5628c9518 --- /dev/null +++ b/gcc-4.9/gcc/testsuite/ada/acats/tests/c3/c3a0010.a @@ -0,0 +1,158 @@ +-- C3A0010.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 access-to-subprogram type in a generic instance may be +-- used to declare access-to-subprogram objects which invoke subprograms +-- in the instance. +-- +-- TEST DESCRIPTION: +-- Declare a numeric type in the visible part of a generic package. +-- Declare two different math procedures that can be referred to by +-- the access to procedure type. +-- +-- In the main program, instantiate the generic. Declare an access +-- to procedure type. Call each procedure indirectly by dereferencing +-- the access value. +-- +-- +-- CHANGE HISTORY: +-- 06 Dec 94 SAIC ACVC 2.0 +-- 05 APR 96 SAIC Header correction for 2.1 +-- +--! + +generic + type Real_Num is digits <>; + +package C3A0010_0 is + + -- Type accesses to any math procedure + type Math_Procedure_Ptr is access procedure + (First_Num, Second_Num : in Real_Num; + Result_Num : out Real_Num); + + procedure Add (First_Num, Second_Num : in Real_Num; + Result_Num : out Real_Num); + + procedure Subtract (First_Num, Second_Num : in Real_Num; + Result_Num : out Real_Num); + +end C3A0010_0; + + +----------------------------------------------------------------------------- + + +package body C3A0010_0 is + + procedure Add (First_Num, Second_Num : in Real_Num; + Result_Num : out Real_Num) is + begin + Result_Num := First_Num + Second_Num; + end Add; + + + procedure Subtract (First_Num, Second_Num : in Real_Num; + Result_Num : out Real_Num) is + begin + Result_Num := First_Num - Second_Num; + end Subtract; + +end C3A0010_0; + +----------------------------------------------------------------------------- + +with Report; +with C3A0010_0; + +procedure C3A0010 is + + type Real is digits 2; + + subtype Math_Float is Real range -10.0 .. 10.0; + + package Math_Pk is new C3A0010_0 (Real_Num => Math_Float); + + Math_Access : Math_Pk.Math_Procedure_Ptr; + + Total_Num : Math_Float := 0.0; + First_Num : Math_Float := 1.0; + Second_Num : Math_Float := 2.0; + + procedure Max( A_Num, B_Num: in Math_Float; Result : out Math_Float ) is + begin + if A_Num > B_Num then + Result := A_Num; + else + Result := B_Num; + end if; + end Max; + + procedure Due_Process( Process: Math_Pk.Math_Procedure_Ptr ) is + begin + Process(First_Num, Second_Num, Total_Num); + end Due_Process; + +begin + + Report.Test ("C3A0010", "Check that an access-to-subprogram type in a " + & "generic instance may be used to declare " + & "access-to-subprogram objects which invoke " + & "subprograms in the instance"); + +-- Check for correct defaulting + if Math_Pk."/="( Math_Access, null) then + Report.Failed("subprogram access type object not initialized to null"); + end if; + + Math_Access := Math_Pk.Add'Access; + + -- Invoking Add procedure designated by access value + Due_Process( Math_Access ); + + If Total_Num /= 3.0 then + Report.Failed ("Incorrect Add result"); + end if; + + Math_Access := Math_Pk.Subtract'Access; + + Due_Process( Math_Access ); + + If Total_Num /= -1.0 then + Report.Failed ("Incorrect Subtract result"); + end if; + + Math_Access := Max'Access; + + Due_Process( Math_Access ); + + If Total_Num /= 2.0 then + Report.Failed ("Incorrect Max result"); + end if; + + Report.Result; + +end C3A0010; diff --git a/gcc-4.9/gcc/testsuite/ada/acats/tests/c3/c3a0011.a b/gcc-4.9/gcc/testsuite/ada/acats/tests/c3/c3a0011.a new file mode 100644 index 000000000..985080659 --- /dev/null +++ b/gcc-4.9/gcc/testsuite/ada/acats/tests/c3/c3a0011.a @@ -0,0 +1,186 @@ +-- C3A0011.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 access-to-subprogram object whose type is declared in a +-- parent package, may be used to invoke subprograms in a child package. +-- Check that such access objects may be stored in a data structure and +-- that subprograms may be called by walking the data structure. +-- +-- TEST DESCRIPTION: +-- In the package, declare an access to procedure type. Declare an +-- array of the access type. Declare three different procedures that +-- can be referred to by the access to procedure type. +-- +-- In the visible child package, declare two procedures that can be +-- referred to by the access to procedure type of the parent. Build +-- the array by calling each procedure indirectly through the access +-- value. +-- +-- +-- CHANGE HISTORY: +-- 06 Dec 94 SAIC ACVC 2.0 +-- 16 Dec 94 SAIC Improved visibility of "/=" in main body +-- +--! + +package C3A0011_0 is -- Interpreter + + type Compass_Point is mod 360; + + function Heading return Compass_Point; + + -- Type accesses to any procedure + type Action_Ptr is access procedure; + + -- Array of access to procedure + type Action_Array is array (Natural range <>) of Action_Ptr; + + procedure Rotate_Left; + + procedure Rotate_Right; + + procedure Center; + +private + The_Heading : Compass_Point := Compass_Point'First; + +end C3A0011_0; + + +----------------------------------------------------------------------------- + + +package body C3A0011_0 is + + function Heading return Compass_Point is + begin + return The_Heading; + end Heading; + + procedure Rotate_Left is + begin + The_Heading := The_Heading - 90; + end Rotate_Left; + + + procedure Rotate_Right is + begin + The_Heading := The_Heading + 90; + end Rotate_Right; + + + procedure Center is + begin + The_Heading := 0; + end Center; + +end C3A0011_0; + + +----------------------------------------------------------------------------- + + +package C3A0011_0.Action is + + procedure Rotate_Front; + + procedure Rotate_Back; + +end C3A0011_0.Action; + + +----------------------------------------------------------------------------- + + +package body C3A0011_0.Action is + + procedure Rotate_Front is + begin + The_Heading := The_Heading + 5; + end Rotate_Front; + + + procedure Rotate_Back is + begin + The_Heading := The_Heading - 5; + end Rotate_Back; + +end C3A0011_0.Action; + + +----------------------------------------------------------------------------- + + +with C3A0011_0.Action; + +with Report; + +procedure C3A0011 is + + Total_Actions : constant := 6; + + Action_Sequence : C3A0011_0.Action_Array (1 .. Total_Actions); + + type Result_Array is array (Natural range <>) of C3A0011_0.Compass_Point; + + Action_Results : Result_Array(1 .. Total_Actions); + + package IA renames C3A0011_0.Action; + +begin + + Report.Test ("C3A0011", "Check that an access-to-subprogram object whose " + & "type is declared in a parent package, may be " + & "used to invoke subprograms in a child package. " + & "Check that such access objects may be stored in " + & "a data structure and that subprograms may be " + & "called by walking the data structure"); + + -- Build the action sequence + Action_Sequence := (C3A0011_0.Rotate_Left'Access, + C3A0011_0.Center'Access, + C3A0011_0.Rotate_Right'Access, + IA.Rotate_Front'Access, + C3A0011_0.Center'Access, + IA.Rotate_Back'Access); + + -- Build the expected result + Action_Results := ( 270, 0, 90, 95, 0, 355 ); + + -- Assign actions by invoking subprogram designated by access value + for I in Action_Sequence'Range loop + Action_Sequence(I).all; + if C3A0011_0."/="( C3A0011_0.Heading, Action_Results(I) ) then + Report.Failed ("Expecting " + & C3A0011_0.Compass_Point'Image(Action_Results(I)) + & " Got" + & C3A0011_0.Compass_Point'Image(C3A0011_0.Heading)); + end if; + end loop; + + Report.Result; + +end C3A0011; diff --git a/gcc-4.9/gcc/testsuite/ada/acats/tests/c3/c3a00120.a b/gcc-4.9/gcc/testsuite/ada/acats/tests/c3/c3a00120.a new file mode 100644 index 000000000..5ce7b6175 --- /dev/null +++ b/gcc-4.9/gcc/testsuite/ada/acats/tests/c3/c3a00120.a @@ -0,0 +1,83 @@ +-- C3A00120.A + -- +-- Grant of Unlimited Rights +-- +-- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687, +-- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained +-- unlimited rights in the software and documentation contained herein. +-- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making +-- this public release, the Government intends to confer upon all +-- recipients unlimited rights equal to those held by the Government. +-- These rights include rights to use, duplicate, release or disclose the +-- released technical data and computer software in whole or in part, in +-- any manner and for any purpose whatsoever, and to have or permit others +-- to do so. +-- +-- DISCLAIMER +-- +-- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR +-- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED +-- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE +-- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE +-- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A +-- PARTICULAR PURPOSE OF SAID MATERIAL. +--* + -- + -- OBJECTIVE: + -- See file C3A00122.AM + -- + -- TEST DESCRIPTION: + -- See file C3A00122.AM + -- + -- TEST FILES: + -- The following files comprise this test: + -- + -- => C3A00120.A + -- C3A00121.A + -- C3A00122.AM + -- + -- +-- CHANGE HISTORY: +-- 06 Dec 94 SAIC ACVC 2.0 +-- + --! + + package C3A0012_0 is + + type Call_Kind is (No_Call_Made, Fast_Call, Accurate_Call, + Table_Lookup_Call); + + Log_Result : Float := 0.0; + + -- Type accesses to any log procedure + type Log_Procedure_Ptr is access procedure + (Angle : in Float; Log_Call : out Call_Kind); + + procedure Log_Calc_Fast (Angle : in Float; + Method : out Call_Kind); + + procedure Log_Calc_Acc (Angle : in Float; + Method : out Call_Kind); + + procedure Log_Calc_Table (Angle : in Float; + Method : out Call_Kind); + + end C3A0012_0; + + + --=======================================================================-- + + + package body C3A0012_0 is + + procedure Log_Calc_Fast (Angle : in Float; + Method : out Call_Kind) is separate; + + procedure Log_Calc_Acc (Angle : in Float; + Method : out Call_Kind) is separate; + + procedure Log_Calc_Table (Angle : in Float; + Method : out Call_Kind) is separate; + + end C3A0012_0; + diff --git a/gcc-4.9/gcc/testsuite/ada/acats/tests/c3/c3a00121.a b/gcc-4.9/gcc/testsuite/ada/acats/tests/c3/c3a00121.a new file mode 100644 index 000000000..acb1dab99 --- /dev/null +++ b/gcc-4.9/gcc/testsuite/ada/acats/tests/c3/c3a00121.a @@ -0,0 +1,76 @@ +-- C3A00121.A + -- +-- Grant of Unlimited Rights +-- +-- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687, +-- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained +-- unlimited rights in the software and documentation contained herein. +-- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making +-- this public release, the Government intends to confer upon all +-- recipients unlimited rights equal to those held by the Government. +-- These rights include rights to use, duplicate, release or disclose the +-- released technical data and computer software in whole or in part, in +-- any manner and for any purpose whatsoever, and to have or permit others +-- to do so. +-- +-- DISCLAIMER +-- +-- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR +-- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED +-- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE +-- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE +-- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A +-- PARTICULAR PURPOSE OF SAID MATERIAL. +--* + -- + -- OBJECTIVE: + -- See file C3A00122.AM + -- + -- TEST DESCRIPTION: + -- See file C3A00122.AM + -- + -- TEST FILES: + -- The following files comprise this test: + -- + -- C3A00120.A + -- => C3A00121.A + -- C3A00122.AM + -- + -- +-- CHANGE HISTORY: +-- 06 Dec 94 SAIC ACVC 2.0 +-- + --! + + Separate (C3A0012_0) + procedure Log_Calc_Fast (Angle : in Float; + Method : out Call_Kind) is + begin + C3A0012_0.Log_Result := Angle; + Method := Fast_Call; + end Log_Calc_Fast; + + + --=======================================================================-- + + + Separate (C3A0012_0) + procedure Log_Calc_Acc (Angle : in Float; + Method : out Call_Kind) is + begin + C3A0012_0.Log_Result := Angle; + Method := Accurate_Call; + end Log_Calc_Acc; + + + --=======================================================================-- + + + Separate (C3A0012_0) + procedure Log_Calc_Table (Angle : in Float; + Method : out Call_Kind) is + begin + C3A0012_0.Log_Result := Angle; + Method := Table_Lookup_Call; + end Log_Calc_Table; + diff --git a/gcc-4.9/gcc/testsuite/ada/acats/tests/c3/c3a00122.am b/gcc-4.9/gcc/testsuite/ada/acats/tests/c3/c3a00122.am new file mode 100644 index 000000000..7af03c256 --- /dev/null +++ b/gcc-4.9/gcc/testsuite/ada/acats/tests/c3/c3a00122.am @@ -0,0 +1,113 @@ +-- C3A00122.AM +-- +-- Grant of Unlimited Rights +-- +-- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687, +-- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained +-- unlimited rights in the software and documentation contained herein. +-- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making +-- this public release, the Government intends to confer upon all +-- recipients unlimited rights equal to those held by the Government. +-- These rights include rights to use, duplicate, release or disclose the +-- released technical data and computer software in whole or in part, in +-- any manner and for any purpose whatsoever, and to have or permit others +-- to do so. +-- +-- DISCLAIMER +-- +-- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR +-- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED +-- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE +-- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE +-- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A +-- PARTICULAR PURPOSE OF SAID MATERIAL. +--* +-- +-- OBJECTIVE: +-- Check that an access-to-subprogram object can be used to invoke a +-- subprogram when the subprogram body had been declared and implemented +-- as a subunit. +-- +-- TEST DESCRIPTION: +-- Declare an access to procedure type in a main program. Declare +-- three different log subprogram body stubs that can be referred to by +-- the access to procedure type. +-- +-- Complete bodies of the log procedures. +-- +-- In the main program, each procedure will be called indirectly by +-- dereferencing the access value. +-- +-- TEST FILES: +-- The following files comprise this test: +-- +-- C3A00120.A +-- C3A00121.A +-- => C3A00122.AM +-- +-- +-- CHANGE HISTORY: +-- 06 Dec 94 SAIC ACVC 2.0 +-- +--! + + with Report; + + with C3A0012_0; + + procedure C3A00122 is + + function "="( A,B: C3A0012_0.Call_Kind ) return Boolean + renames C3A0012_0."="; + + Log_Access : C3A0012_0.Log_Procedure_Ptr; + Theta : Float := 0.0; + Method : C3A0012_0.Call_Kind := C3A0012_0.No_Call_Made; + + + + function Due_Process( LA: C3A0012_0.Log_Procedure_Ptr ) + return C3A0012_0.Call_Kind is + Result : C3A0012_0.Call_Kind := C3A0012_0.No_Call_Made; + begin + LA( Theta, Result ); + return Result; + end Due_Process; + + begin + + Report.Test ("C3A0012", "Check that an access to a subprogram object " & + "can be used to select and invoke an operation with " & + "appropriate arguments"); + + Log_Access := C3A0012_0.Log_Calc_Fast'Access; + + -- Invoking Log procedure designated by access value + Method := Due_Process( Log_Access ); + + If Method /= C3A0012_0.Fast_Call then + Report.Failed ("Incorrect Log_Calc_Fast result"); + end if; + + Log_Access := C3A0012_0.Log_Calc_Acc'Access; + + -- Invoking Log procedure designated by access value + Method := Due_Process( Log_Access ); + + If Method /= C3A0012_0.Accurate_Call then + Report.Failed ("Incorrect Log_Calc_Acc result"); + end if; + + Log_Access := C3A0012_0.Log_Calc_Table'Access; + + -- Invoking Log procedure designated by access value + Method := Due_Process( Log_Access ); + + If Method /= C3A0012_0.Table_Lookup_Call then + Report.Failed ("Incorrect Log_Calc_Table result"); + end if; + + Report.Result; + + end C3A00122; + diff --git a/gcc-4.9/gcc/testsuite/ada/acats/tests/c3/c3a0013.a b/gcc-4.9/gcc/testsuite/ada/acats/tests/c3/c3a0013.a new file mode 100644 index 000000000..b23d4ee11 --- /dev/null +++ b/gcc-4.9/gcc/testsuite/ada/acats/tests/c3/c3a0013.a @@ -0,0 +1,347 @@ +-- C3A0013.A +-- +-- Grant of Unlimited Rights +-- +-- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687, +-- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained +-- unlimited rights in the software and documentation contained herein. +-- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making +-- this public release, the Government intends to confer upon all +-- recipients unlimited rights equal to those held by the Government. +-- These rights include rights to use, duplicate, release or disclose the +-- released technical data and computer software in whole or in part, in +-- any manner and for any purpose whatsoever, and to have or permit others +-- to do so. +-- +-- DISCLAIMER +-- +-- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR +-- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED +-- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE +-- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE +-- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A +-- PARTICULAR PURPOSE OF SAID MATERIAL. +--* +-- +-- OBJECTIVE: +-- Check that a general access type object may reference allocated +-- pool objects as well as aliased objects. (3,4) +-- Check that formal parameters of tagged types are implicitly +-- defined as aliased; check that the 'Access of these formal +-- parameters designates the correct object with the correct +-- tag. (5) +-- Check that the current instance of a limited type is defined as +-- aliased. (5) +-- +-- TEST DESCRIPTION: +-- This test takes from the hierarchy defined in C390003; making +-- the root type Vehicle limited private. It also shifts the +-- abstraction to include the notion of a transmission, an object +-- which is contained within any vehicle. Using an access +-- discriminant, any subprogram which operates on a transmission +-- may also reference the vehicle in which it is installed. +-- +-- Class Hierarchy: +-- Vehicle Transmission +-- / \ +-- Truck Car +-- +-- Contains: +-- Vehicle( Transmission ) +-- +-- +-- +-- CHANGE HISTORY: +-- 06 Dec 94 SAIC ACVC 2.0 +-- 16 Dec 94 SAIC Fixed accessibility problems +-- +--! + +package C3A0013_1 is + type Vehicle is tagged limited private; + type Vehicle_ID is access all Vehicle'Class; + + -- Constructors + procedure Create ( It : in out Vehicle; + Wheels : Natural := 4 ); + -- Modifiers + procedure Accelerate ( It : in out Vehicle ); + procedure Decelerate ( It : in out Vehicle ); + procedure Up_Shift ( It : in out Vehicle ); + procedure Stop ( It : in out Vehicle ); + + -- Selectors + function Speed ( It : Vehicle ) return Natural; + function Wheels ( It : Vehicle ) return Natural; + function Gear_Factor( It : Vehicle ) return Natural; + + -- TC_Ops + procedure TC_Validate( It : in out Vehicle; Speed_Trap : Natural ); + + -- dispatching procedure used to check tag correctness + procedure TC_Validate( It : Vehicle; + TC_ID : Character); + +private + + type Transmission(Within: access Vehicle'Class) is limited record + Engaged : Boolean := False; + Gear : Integer range -1..5 := 0; + end record; + + -- Current instance of a limited type is defined as aliased + + type Vehicle is tagged limited record + Wheels: Natural; + Speed : Natural; + Power_Train: Transmission( Vehicle'Access ); + end record; +end C3A0013_1; + +with C3A0013_1; +package C3A0013_2 is + type Car is new C3A0013_1.Vehicle with private; + procedure TC_Validate( It : Car; + TC_ID : Character); + function Gear_Factor( It : Car ) return Natural; +private + type Car is new C3A0013_1.Vehicle with record + Displacement : Natural; + end record; +end C3A0013_2; + +with C3A0013_1; +package C3A0013_3 is + type Truck is new C3A0013_1.Vehicle with private; + procedure TC_Validate( It : Truck; + TC_ID : Character); + function Gear_Factor( It : Truck ) return Natural; +private + type Truck is new C3A0013_1.Vehicle with record + Displacement : Natural; + end record; +end C3A0013_3; + +with Report; +package body C3A0013_1 is + + procedure Create ( It : in out Vehicle; + Wheels : Natural := 4 ) is + begin + It.Wheels := Wheels; + It.Speed := 0; + end Create; + + procedure Accelerate( It : in out Vehicle ) is + begin + It.Speed := It.Speed + Gear_Factor( It.Power_Train.Within.all ); + end Accelerate; + + procedure Decelerate( It : in out Vehicle ) is + begin + It.Speed := It.Speed - Gear_Factor( It.Power_Train.Within.all ); + end Decelerate; + + procedure Stop ( It : in out Vehicle ) is + begin + It.Speed := 0; + It.Power_Train.Engaged := False; + end Stop; + + function Gear_Factor( It : Vehicle ) return Natural is + begin + return It.Power_Train.Gear; + end Gear_Factor; + + function Speed ( It : Vehicle ) return Natural is + begin + return It.Speed; + end Speed; + + function Wheels ( It : Vehicle ) return Natural is + begin + return It.Wheels; + end Wheels; + + -- formal tagged parameters are implicitly aliased + + procedure TC_Validate( It : in out Vehicle; Speed_Trap : Natural ) is + License: Vehicle_ID := It'Unchecked_Access; + begin + if Speed( License.all ) /= Speed_Trap then + Report.Failed("Speed Trap: expected: " & Natural'Image(Speed_Trap)); + end if; + end TC_Validate; + + procedure TC_Validate( It : Vehicle; + TC_ID : Character) is + begin + if TC_ID /= 'V' then + Report.Failed("Dispatched to Vehicle"); + end if; + if Wheels( It ) /= 1 then + Report.Failed("Not a Vehicle"); + end if; + end TC_Validate; + + procedure Up_Shift( It: in out Vehicle ) is + begin + It.Power_Train.Gear := It.Power_Train.Gear +1; + It.Power_Train.Engaged := True; + Accelerate( It ); + end Up_Shift; +end C3A0013_1; + +with Report; +package body C3A0013_2 is + + procedure TC_Validate( It : Car; + TC_ID : Character ) is + begin + if TC_ID /= 'C' then + Report.Failed("Dispatched to Car"); + end if; + if Wheels( It ) /= 4 then + Report.Failed("Not a Car"); + end if; + end TC_Validate; + + function Gear_Factor( It : Car ) return Natural is + begin + return C3A0013_1.Gear_Factor( C3A0013_1.Vehicle( It ) )*2; + end Gear_Factor; + +end C3A0013_2; + +with Report; +package body C3A0013_3 is + + procedure TC_Validate( It : Truck; + TC_ID : Character) is + begin + if TC_ID /= 'T' then + Report.Failed("Dispatched to Truck"); + end if; + if Wheels( It ) /= 3 then + Report.Failed("Not a Truck"); + end if; + end TC_Validate; + + function Gear_Factor( It : Truck ) return Natural is + begin + return C3A0013_1.Gear_Factor( C3A0013_1.Vehicle( It ) )*3; + end Gear_Factor; + +end C3A0013_3; + +package C3A0013_4 is + procedure Perform_Tests; +end C3A0013_4; + +with Report; +with C3A0013_1; +with C3A0013_2; +with C3A0013_3; +package body C3A0013_4 is + package Root renames C3A0013_1; + package Cars renames C3A0013_2; + package Trucks renames C3A0013_3; + + type Car_Pool is array(1..4) of aliased Cars.Car; + Commuters : Car_Pool; + + My_Car : aliased Cars.Car; + Company_Car : Root.Vehicle_ID; + Repair_Shop : Root.Vehicle_ID; + + The_Vehicle : Root.Vehicle; + The_Car : Cars.Car; + The_Truck : Trucks.Truck; + + procedure TC_Dispatch( Ptr : Root.Vehicle_ID; + Char : Character ) is + begin + Root.TC_Validate( Ptr.all, Char ); + end TC_Dispatch; + + procedure TC_Check_Formal_Access( Item: in out Root.Vehicle'Class; + Char: Character) is + begin + TC_Dispatch( Item'Unchecked_Access, Char ); + end TC_Check_Formal_Access; + + procedure Perform_Tests is + begin -- Main test procedure. + + for Lane in Commuters'Range loop + Cars.Create( Commuters(Lane) ); + for Excitement in 1..Lane loop + Cars.Up_Shift( Commuters(Lane) ); + end loop; + end loop; + + Cars.Create( My_Car ); + Cars.Up_Shift( My_Car ); + Cars.TC_Validate( My_Car, 2 ); + + Root.Create( The_Vehicle, 1 ); + Cars.Create( The_Car , 4 ); + Trucks.Create( The_Truck, 3 ); + + TC_Check_Formal_Access( The_Vehicle, 'V' ); + TC_Check_Formal_Access( The_Car, 'C' ); + TC_Check_Formal_Access( The_Truck, 'T' ); + + Root.Up_Shift( The_Vehicle ); + Cars.Up_Shift( The_Car ); + Trucks.Up_Shift( The_Truck ); + + Root.TC_Validate( The_Vehicle, 1 ); + Cars.TC_Validate( The_Car, 2 ); + Trucks.TC_Validate( The_Truck, 3 ); + + -- general access type may reference allocated objects + + Company_Car := new Cars.Car; + Root.Create( Company_Car.all ); + Root.Up_Shift( Company_Car.all ); + Root.Up_Shift( Company_Car.all ); + Root.TC_Validate( Company_Car.all, 6 ); + + -- general access type may reference aliased objects + + Repair_Shop := My_Car'Access; + Root.TC_Validate( Repair_Shop.all, 2 ); + + -- general access type may reference aliased objects + + Construction: declare + type Speed_List is array(Commuters'Range) of Natural; + Accelerations : constant Speed_List := (2, 6, 12, 20); + begin + for Rotation in Commuters'Range loop + Repair_Shop := Commuters(Rotation)'Access; + Root.TC_Validate( Repair_Shop.all, Accelerations(Rotation) ); + end loop; + end Construction; + +end Perform_Tests; + +end C3A0013_4; + +with C3A0013_4; +with Report; +procedure C3A0013 is +begin + + Report.Test ("C3A0013", "Check general access types. Check aliased " + & "nature of formal tagged type parameters. " + & "Check aliased nature of the current " + & "instance of a limited type. Check the " + & "constraining of actual subtypes for " + & "discriminated objects" ); + + C3A0013_4.Perform_Tests; + + Report.Result; +end C3A0013; diff --git a/gcc-4.9/gcc/testsuite/ada/acats/tests/c3/c3a0014.a b/gcc-4.9/gcc/testsuite/ada/acats/tests/c3/c3a0014.a new file mode 100644 index 000000000..c83ab4f5e --- /dev/null +++ b/gcc-4.9/gcc/testsuite/ada/acats/tests/c3/c3a0014.a @@ -0,0 +1,453 @@ +-- C3A0014.A +-- +-- Grant of Unlimited Rights +-- +-- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687, +-- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained +-- unlimited rights in the software and documentation contained herein. +-- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making +-- this public release, the Government intends to confer upon all +-- recipients unlimited rights equal to those held by the Government. +-- These rights include rights to use, duplicate, release or disclose the +-- released technical data and computer software in whole or in part, in +-- any manner and for any purpose whatsoever, and to have or permit others +-- to do so. +-- +-- DISCLAIMER +-- +-- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR +-- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED +-- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE +-- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE +-- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A +-- PARTICULAR PURPOSE OF SAID MATERIAL. +--* +-- +-- OBJECTIVE: +-- Check that if the view defined by an object declaration is aliased, +-- and the type of the object has discriminants, then the object is +-- constrained by its initial value even if its nominal subtype is +-- unconstrained. +-- +-- Check that the attribute A'Constrained returns True if A is a formal +-- out or in out parameter, or dereference thereof, and A denotes an +-- aliased view of an object. +-- +-- TEST DESCRIPTION: +-- These rules apply to objects of a record type with defaulted +-- discriminants, which may be unconstrained variables. If such a +-- variable is declared to be aliased, then it is constrained by its +-- initial value, and the value of the discriminant cannot be changed +-- for the life of the variable. +-- +-- The rules do not apply to aliased component types because if such +-- types are discriminated they must be constrained. +-- +-- A'Constrained returns True if A denotes a constant, value, or +-- constrained variable. Since aliased objects are constrained, it must +-- return True if the actual parameter corresponding to a formal +-- parameter A is an aliased object. The objective only mentions formal +-- parameters of mode out and in out, since parameters of mode in are +-- by definition constant, and would result in True anyway. +-- +-- This test declares aliased objects of a nominally unconstrained +-- record subtype, both with and without initialization expressions. +-- It also declares access values which point to such objects. It then +-- checks that Constraint_Error is raised if an attempt is made to +-- change the discriminant value of an aliased object, either directly +-- or via a dereference of an access value. For aliased objects, this +-- check is also performed for subprogram parameters of mode out. +-- +-- The test also passes aliased objects and access values which point +-- to such objects as actuals to subprograms and verifies, for parameter +-- modes out and in out, that P'Constrained returns true if P is the +-- corresponding formal parameter or a dereference thereof. +-- +-- Additionally, the test declares a generic package which declares a +-- an aliased object of a formal derived unconstrained type, which is +-- is initialized with the value of a formal object of that type. +-- procedure declared within the generic assigns a value to the object +-- which has the same discriminant value as the formal derived type's +-- ancestor type. The generic is instantiated with various actuals +-- for the formal object, and the procedure is called. The test verifies +-- that Constraint_Error is raised if the discriminant values of the +-- actual corresponding to the formal object and the value assigned +-- by the procedure are not equal. +-- +-- +-- CHANGE HISTORY: +-- 06 Dec 94 SAIC ACVC 2.0 +-- 16 Nov 95 SAIC ACVC 2.0.1 fixes: Corrected numerous errors. +-- +--! + +package C3A0014_0 is + + subtype Reasonable is Integer range 1..10; + -- Unconstrained (sub)type. + type UC (D: Reasonable := 2) is record -- Discriminant default. + S: String (1 .. D) := "Hi"; -- Default value. + end record; + + type AUC is access all UC; + + -- Nominal subtype is unconstrained for the following: + + Obj0 : UC; -- An unconstrained object. + + Obj1 : UC := (5, "Hello"); -- Non-aliased with initialization, + -- an unconstrained object. + + Obj2 : aliased UC := (5, "Hello"); -- Aliased with initialization, + -- a constrained object. + + Obj3 : UC renames Obj2; -- Aliased (renaming of aliased view), + -- a constrained object. + Obj4 : aliased UC; -- Aliased without initialization, Obj4 + -- constrained here to initial value + -- taken from default for type. + + Ptr1 : AUC := new UC'(Obj1); + Ptr2 : AUC := new UC; + Ptr3 : AUC := Obj3'Access; + Ptr4 : AUC := Obj4'Access; + + + procedure NP_Proc (A: out UC); + procedure NP_Cons (A: in out UC; B: out Boolean); + procedure P_Cons (A: out AUC; B: out Boolean); + + + generic + type FT is new UC; + FObj : in out FT; + package Gen is + F : aliased FT := FObj; -- Constrained if FT has discriminants. + procedure Proc; + end Gen; + + + procedure Avoid_Optimization_and_Fail ( P : UC; Msg : String ); + + +end C3A0014_0; + + + --=======================================================================-- + +with Report; + +package body C3A0014_0 is + + procedure NP_Proc (A: out UC) is + begin + A := (3, "Bye"); + end NP_Proc; + + procedure NP_Cons (A: in out UC; B: out Boolean) is + begin + B := A'Constrained; + end NP_Cons; + + procedure P_Cons (A: out AUC; B: out Boolean) is + begin + B := A.all'Constrained; + end P_Cons; + + + package body Gen is + + procedure Proc is + begin + F := (2, "Fi"); + end Proc; + + end Gen; + + + procedure Avoid_Optimization_and_Fail ( P : UC; Msg : String ) is + Default : UC := (1, "!"); -- Unique value. + begin + if P = Default then -- Both If branches can't do the same thing. + Report.Failed (Msg & ": Constraint_Error not raised"); + else -- Subtests should always select this path. + Report.Failed ("Constraint_Error not raised " & Msg); + end if; + end Avoid_Optimization_and_Fail; + + +end C3A0014_0; + + + --=======================================================================-- + + +with C3A0014_0; use C3A0014_0; +with Report; + +procedure C3A0014 is +begin + + Report.Test("C3A0014", "Check that if the view defined by an object " & + "declaration is aliased, and the type of the " & + "object has discriminants, then the object is " & + "constrained by its initial value even if its " & + "nominal subtype is unconstrained. Check that " & + "the attribute A'Constrained returns True if A " & + "is a formal out or in out parameter, or " & + "dereference thereof, and A denotes an aliased " & + "view of an object"); + + Non_Pointer_Block: + begin + + begin + Obj0 := (3, "Bye"); -- OK: Obj0 not constrained. + if Obj0 /= (3, "Bye") then + Report.Failed + ("Wrong value after aggregate assignment - Subtest 1"); + end if; + exception + when others => + Report.Failed ("Unexpected exception raised - Subtest 1"); + end; + + + begin + Obj1 := (3, "Bye"); -- OK: Obj1 not constrained. + if Obj1 /= (3, "Bye") then + Report.Failed + ("Wrong value after aggregate assignment - Subtest 2"); + end if; + exception + when others => + Report.Failed ("Unexpected exception raised - Subtest 2"); + end; + + + begin + Obj2 := (3, "Bye"); -- C_E: Obj2 is constrained (D=>5). + Avoid_Optimization_and_Fail (Obj2, "Subtest 3"); + exception + when Constraint_Error => null; -- Exception is expected. + end; + + + begin + Obj3 := (3, "Bye"); -- C_E: Obj3 is constrained (D=>5). + Avoid_Optimization_and_Fail (Obj3, "Subtest 4"); + exception + when Constraint_Error => null; -- Exception is expected. + end; + + + begin + Obj4 := (3, "Bye"); -- C_E: Obj4 is constrained (D=>2). + Avoid_Optimization_and_Fail (Obj4, "Subtest 5"); + exception + when Constraint_Error => null; -- Exception is expected. + end; + + exception + when others => Report.Failed("Unexpected exception: Non_Pointer_Block"); + end Non_Pointer_Block; + + + Pointer_Block: + begin + + begin + Ptr1.all := (3, "Bye"); -- C_E: Ptr1.all is constrained (D=>5). + Avoid_Optimization_and_Fail (Ptr1.all, "Subtest 6"); + exception + when Constraint_Error => null; -- Exception is expected. + end; + + + begin + Ptr2.all := (3, "Bye"); -- C_E: Ptr2.all is constrained (D=>2). + Avoid_Optimization_and_Fail (Ptr2.all, "Subtest 7"); + exception + when Constraint_Error => null; -- Exception is expected. + end; + + + begin + Ptr3.all := (3, "Bye"); -- C_E: Ptr3.all is constrained (D=>5). + Avoid_Optimization_and_Fail (Ptr3.all, "Subtest 8"); + exception + when Constraint_Error => null; -- Exception is expected. + end; + + + begin + Ptr4.all := (3, "Bye"); -- C_E: Ptr4.all is constrained (D=>2). + Avoid_Optimization_and_Fail (Ptr4.all, "Subtest 9"); + exception + when Constraint_Error => null; -- Exception is expected. + end; + + exception + when others => Report.Failed("Unexpected exception: Pointer_Block"); + end Pointer_Block; + + + Subprogram_Block: + declare + Is_Constrained : Boolean; + begin + + begin + NP_Proc (Obj0); -- OK: Obj0 not constrained, can + if Obj0 /= (3, "Bye") then -- change discriminant value. + Report.Failed + ("Wrong value after aggregate assignment - Subtest 10"); + end if; + exception + when others => + Report.Failed ("Unexpected exception raised - Subtest 10"); + end; + + + begin + NP_Proc (Obj2); -- C_E: Obj2 is constrained (D=>5). + Avoid_Optimization_and_Fail (Obj2, "Subtest 11"); + exception + when Constraint_Error => null; -- Exception is expected. + end; + + + begin + NP_Proc (Obj3); -- C_E: Obj3 is constrained (D=>5). + Avoid_Optimization_and_Fail (Obj3, "Subtest 12"); + exception + when Constraint_Error => null; -- Exception is expected. + end; + + + begin + NP_Proc (Obj4); -- C_E: Obj4 is constrained (D=>2). + Avoid_Optimization_and_Fail (Obj4, "Subtest 13"); + exception + when Constraint_Error => null; -- Exception is expected. + end; + + + + begin + Is_Constrained := True; + NP_Cons (Obj1, Is_Constrained); -- Should return False, since Obj1 + if Is_Constrained then -- is not constrained. + Report.Failed ("Wrong result from 'Constrained - Subtest 14"); + end if; + exception + when others => + Report.Failed ("Unexpected exception raised - Subtest 14"); + end; + + + begin + Is_Constrained := False; + NP_Cons (Obj2, Is_Constrained); -- Should return True, Obj2 is + if not Is_Constrained then -- constrained. + Report.Failed ("Wrong result from 'Constrained - Subtest 15"); + end if; + exception + when others => + Report.Failed ("Unexpected exception raised - Subtest 15"); + end; + + + + + begin + Is_Constrained := False; + P_Cons (Ptr2, Is_Constrained); -- Should return True, Ptr2.all + if not Is_Constrained then -- is constrained. + Report.Failed ("Wrong result from 'Constrained - Subtest 16"); + end if; + exception + when others => + Report.Failed ("Unexpected exception raised - Subtest 16"); + end; + + + begin + Is_Constrained := False; + P_Cons (Ptr3, Is_Constrained); -- Should return True, Ptr3.all + if not Is_Constrained then -- is constrained. + Report.Failed ("Wrong result from 'Constrained - Subtest 17"); + end if; + exception + when others => + Report.Failed ("Unexpected exception raised - Subtest 17"); + end; + + + exception + when others => Report.Failed("Exception raised in Subprogram_Block"); + end Subprogram_Block; + + + Generic_Block: + declare + + type NUC is new UC; + + Obj : NUC; + + + package Instance_A is new Gen (NUC, Obj); + package Instance_B is new Gen (UC, Obj2); + package Instance_C is new Gen (UC, Obj3); + package Instance_D is new Gen (UC, Obj4); + + begin + + begin + Instance_A.Proc; -- OK: Obj.D = 2. + if Instance_A.F /= (2, "Fi") then + Report.Failed + ("Wrong value after aggregate assignment - Subtest 18"); + end if; + exception + when others => + Report.Failed ("Unexpected exception raised - Subtest 18"); + end; + + + begin + Instance_B.Proc; -- C_E: Obj2.D = 5. + Avoid_Optimization_and_Fail (Obj2, "Subtest 19"); + exception + when Constraint_Error => null; -- Exception is expected. + end; + + + begin + Instance_C.Proc; -- C_E: Obj3.D = 5. + Avoid_Optimization_and_Fail (Obj3, "Subtest 20"); + exception + when Constraint_Error => null; -- Exception is expected. + end; + + + begin + Instance_D.Proc; -- OK: Obj4.D = 2. + if Instance_D.F /= (2, "Fi") then + Report.Failed + ("Wrong value after aggregate assignment - Subtest 21"); + end if; + exception + when others => + Report.Failed ("Unexpected exception raised - Subtest 21"); + end; + + exception + when others => Report.Failed("Exception raised in Generic_Block"); + end Generic_Block; + + + Report.Result; + +end C3A0014; diff --git a/gcc-4.9/gcc/testsuite/ada/acats/tests/c3/c3a0015.a b/gcc-4.9/gcc/testsuite/ada/acats/tests/c3/c3a0015.a new file mode 100644 index 000000000..856c910f9 --- /dev/null +++ b/gcc-4.9/gcc/testsuite/ada/acats/tests/c3/c3a0015.a @@ -0,0 +1,267 @@ +-- C3A0015.A +-- +-- Grant of Unlimited Rights +-- +-- The Ada Conformity Assessment Authority (ACAA) holds unlimited +-- rights in the software and documentation contained herein. Unlimited +-- rights are the same as those granted by the U.S. Government for older +-- parts of the Ada Conformity Assessment Test Suite, and are defined +-- in DFAR 252.227-7013(a)(19). By making this public release, the ACAA +-- intends to confer upon all recipients unlimited rights equal to those +-- held by the ACAA. These rights include rights to use, duplicate, +-- release or disclose the released technical data and computer software +-- in whole or in part, in any manner and for any purpose whatsoever, and +-- to have or permit others to do so. +-- +-- DISCLAIMER +-- +-- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR +-- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED +-- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE +-- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE +-- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A +-- PARTICULAR PURPOSE OF SAID MATERIAL. +--* +-- +-- OBJECTIVE: +-- Check that a derived access type has the same storage pool as its +-- parent. (Defect Report 8652/0012, Technical Corrigendum 3.10(7/1)). +-- +-- CHANGE HISTORY: +-- 24 JAN 2001 PHL Initial version. +-- 29 JUN 2001 RLB Reformatted for ACATS. +-- +--! +with System.Storage_Elements; +use System.Storage_Elements; +with System.Storage_Pools; +use System.Storage_Pools; +package C3A0015_0 is + + type Pool (Storage_Size : Storage_Count) is new Root_Storage_Pool with + record + First_Free : Storage_Count := 1; + Contents : Storage_Array (1 .. Storage_Size); + end record; + + procedure Allocate (Pool : in out C3A0015_0.Pool; + Storage_Address : out System.Address; + Size_In_Storage_Elements : in Storage_Count; + Alignment : in Storage_Count); + + procedure Deallocate (Pool : in out C3A0015_0.Pool; + Storage_Address : in System.Address; + Size_In_Storage_Elements : in Storage_Count; + Alignment : in Storage_Count); + + function Storage_Size (Pool : in C3A0015_0.Pool) return Storage_Count; + +end C3A0015_0; + +package body C3A0015_0 is + + use System; + + procedure Allocate (Pool : in out C3A0015_0.Pool; + Storage_Address : out System.Address; + Size_In_Storage_Elements : in Storage_Count; + Alignment : in Storage_Count) is + Unaligned_Address : constant System.Address := + Pool.Contents (Pool.First_Free)'Address; + Unalignment : Storage_Count; + begin + Unalignment := Unaligned_Address mod Alignment; + if Unalignment = 0 then + Storage_Address := Unaligned_Address; + Pool.First_Free := Pool.First_Free + Size_In_Storage_Elements; + else + Storage_Address := + Pool.Contents (Pool.First_Free + Alignment - Unalignment)' + Address; + Pool.First_Free := Pool.First_Free + Size_In_Storage_Elements + + Alignment - Unalignment; + end if; + end Allocate; + + procedure Deallocate (Pool : in out C3A0015_0.Pool; + Storage_Address : in System.Address; + Size_In_Storage_Elements : in Storage_Count; + Alignment : in Storage_Count) is + begin + if Storage_Address + Size_In_Storage_Elements = + Pool.Contents (Pool.First_Free)'Address then + -- Only deallocate if the block is at the end. + Pool.First_Free := Pool.First_Free - Size_In_Storage_Elements; + end if; + end Deallocate; + + function Storage_Size (Pool : in C3A0015_0.Pool) return Storage_Count is + begin + return Pool.Storage_Size; + end Storage_Size; + +end C3A0015_0; + +with Ada.Exceptions; +use Ada.Exceptions; +with Ada.Unchecked_Deallocation; +with Report; +use Report; +with System.Storage_Elements; +use System.Storage_Elements; +with C3A0015_0; +procedure C3A0015 is + + type Standard_Pool is access Float; + type Derived_Standard_Pool is new Standard_Pool; + type Derived_Derived_Standard_Pool is new Derived_Standard_Pool; + + type User_Defined_Pool is access Integer; + type Derived_User_Defined_Pool is new User_Defined_Pool; + type Derived_Derived_User_Defined_Pool is new Derived_User_Defined_Pool; + + My_Pool : C3A0015_0.Pool (1024); + for User_Defined_Pool'Storage_Pool use My_Pool; + + generic + type Designated is private; + Value : Designated; + type Acc is access Designated; + type Derived_Acc is new Acc; + procedure Check (Subtest : String; User_Defined_Pool : Boolean); + + procedure Check (Subtest : String; User_Defined_Pool : Boolean) is + + procedure Deallocate is + new Ada.Unchecked_Deallocation (Object => Designated, + Name => Acc); + procedure Deallocate is + new Ada.Unchecked_Deallocation (Object => Designated, + Name => Derived_Acc); + + First_Free : Storage_Count; + X : Acc; + Y : Derived_Acc; + begin + if User_Defined_Pool then + First_Free := My_Pool.First_Free; + end if; + X := new Designated'(Value); + if User_Defined_Pool and then First_Free >= My_Pool.First_Free then + Failed (Subtest & + " - Allocation didn't consume storage in the pool - 1"); + else + First_Free := My_Pool.First_Free; + end if; + + Y := Derived_Acc (X); + if User_Defined_Pool and then First_Free /= My_Pool.First_Free then + Failed (Subtest & + " - Conversion did consume storage in the pool - 1"); + end if; + if Y.all /= Value then + Failed (Subtest & + " - Incorrect allocation/conversion of access values - 1"); + end if; + + Deallocate (Y); + if User_Defined_Pool and then First_Free <= My_Pool.First_Free then + Failed (Subtest & + " - Deallocation didn't release storage from the pool - 1"); + else + First_Free := My_Pool.First_Free; + end if; + + Y := new Designated'(Value); + if User_Defined_Pool and then First_Free >= My_Pool.First_Free then + Failed (Subtest & + " - Allocation didn't consume storage in the pool - 2"); + else + First_Free := My_Pool.First_Free; + end if; + + X := Acc (Y); + if User_Defined_Pool and then First_Free /= My_Pool.First_Free then + Failed (Subtest & + " - Conversion did consume storage in the pool - 2"); + end if; + if X.all /= Value then + Failed (Subtest & + " - Incorrect allocation/conversion of access values - 2"); + end if; + + Deallocate (X); + if User_Defined_Pool and then First_Free <= My_Pool.First_Free then + Failed (Subtest & + " - Deallocation didn't release storage from the pool - 2"); + end if; + exception + when E: others => + Failed (Subtest & " - Exception " & Exception_Name (E) & + " raised - " & Exception_Message (E)); + end Check; + + +begin + Test ("C3A0015", "Check that a dervied access type has the same " & + "storage pool as its parent"); + + Comment ("Access types using the standard storage pool"); + + Std: + declare + procedure Check1 is + new Check (Designated => Float, + Value => 3.0, + Acc => Standard_Pool, + Derived_Acc => Derived_Standard_Pool); + procedure Check2 is + new Check (Designated => Float, + Value => 4.0, + Acc => Standard_Pool, + Derived_Acc => Derived_Derived_Standard_Pool); + procedure Check3 is + new Check (Designated => Float, + Value => 5.0, + Acc => Derived_Standard_Pool, + Derived_Acc => Derived_Derived_Standard_Pool); + begin + Check1 ("Standard_Pool/Derived_Standard_Pool", + User_Defined_Pool => False); + Check2 ("Standard_Pool/Derived_Derived_Standard_Pool", + User_Defined_Pool => False); + Check3 ("Derived_Standard_Pool/Derived_Derived_Standard_Pool", + User_Defined_Pool => False); + end Std; + + Comment ("Access types using a user-defined storage pool"); + + User: + declare + procedure Check1 is + new Check (Designated => Integer, + Value => 17, + Acc => User_Defined_Pool, + Derived_Acc => Derived_User_Defined_Pool); + procedure Check2 is + new Check (Designated => Integer, + Value => 18, + Acc => User_Defined_Pool, + Derived_Acc => Derived_Derived_User_Defined_Pool); + procedure Check3 is + new Check (Designated => Integer, + Value => 19, + Acc => Derived_User_Defined_Pool, + Derived_Acc => Derived_Derived_User_Defined_Pool); + begin + Check1 ("User_Defined_Pool/Derived_User_Defined_Pool", + User_Defined_Pool => True); + Check2 ("User_Defined_Pool/Derived_Derived_User_Defined_Pool", + User_Defined_Pool => True); + Check3 + ("Derived_User_Defined_Pool/Derived_Derived_User_Defined_Pool", + User_Defined_Pool => True); + end User; + + Result; +end C3A0015; diff --git a/gcc-4.9/gcc/testsuite/ada/acats/tests/c3/c3a1001.a b/gcc-4.9/gcc/testsuite/ada/acats/tests/c3/c3a1001.a new file mode 100644 index 000000000..9b05b5da2 --- /dev/null +++ b/gcc-4.9/gcc/testsuite/ada/acats/tests/c3/c3a1001.a @@ -0,0 +1,315 @@ +-- C3A1001.A +-- +-- Grant of Unlimited Rights +-- +-- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687, +-- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained +-- unlimited rights in the software and documentation contained herein. +-- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making +-- this public release, the Government intends to confer upon all +-- recipients unlimited rights equal to those held by the Government. +-- These rights include rights to use, duplicate, release or disclose the +-- released technical data and computer software in whole or in part, in +-- any manner and for any purpose whatsoever, and to have or permit others +-- to do so. +-- +-- DISCLAIMER +-- +-- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR +-- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED +-- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE +-- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE +-- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A +-- PARTICULAR PURPOSE OF SAID MATERIAL. +--* +-- +-- OBJECTIVE: +-- Check that the full type completing a type with no discriminant part +-- or an unknown discriminant part may have explicitly declared or +-- inherited discriminants. +-- Check for cases where the types are records and protected types. +-- +-- TEST DESCRIPTION: +-- Declare two groups of incomplete types: one group with no discriminant +-- part and one group with unknown discriminant part. Both groups of +-- incomplete types are completed with both explicit and inherited +-- discriminants. Discriminants for record and protected types are +-- declared with default and non default values. +-- In the main program, verify that objects of both groups of incomplete +-- types can be created by default values or by assignments. +-- +-- +-- CHANGE HISTORY: +-- 11 Oct 95 SAIC Initial prerelease version. +-- 11 Nov 96 SAIC Revised for version 2.1. +-- +--! + +package C3A1001_0 is + + type Incomplete1 (<>); -- unknown discriminant + + type Incomplete2; -- no discriminant + + type Incomplete3 (<>); -- unknown discriminant + + type Incomplete4; -- no discriminant + + type Incomplete5 (<>); -- unknown discriminant + + type Incomplete6; -- no discriminant + + type Incomplete8; -- no discriminant + + subtype Small_Int is Integer range 1 .. 10; + + type Enu_Type is (M, F); + + type Incomplete1 (Disc : Enu_Type) is -- unknown discriminant/ + record -- explicit discriminant + case Disc is + when M => MInteger : Small_Int := 3; + when F => FInteger : Small_Int := 8; + end case; + end record; + + type Incomplete2 (Disc : Small_Int := 8) is -- no discriminant/ + record -- explicit discriminant + ID : String (1 .. Disc) := "Plymouth"; + end record; + + type Incomplete3 is new Incomplete2; -- unknown discriminant/ + -- inherited discriminant + + type Incomplete4 is new Incomplete2; -- no discriminant/ + -- inherited discriminant + + protected type Incomplete5 -- unknown discriminant/ + (Disc : Enu_Type) is -- explicit discriminant + function Get_Priv_Val return Enu_Type; + private + Enu_Obj : Enu_Type := Disc; + end Incomplete5; + + protected type Incomplete6 -- no discriminant/ + (Disc : Small_Int := 1) is -- explicit discriminant + function Get_Priv_Val return Small_Int; -- with default + private + Num : Small_Int := Disc; + end Incomplete6; + + type Incomplete8 (Disc : Small_Int) is -- no discriminant/ + record -- explicit discriminant + Str : String (1 .. Disc); -- no default + end record; + + type Incomplete9 is new Incomplete8; + + function Return_String (S : String) return String; + +end C3A1001_0; + + --==================================================================-- + +with Report; + +package body C3A1001_0 is + + protected body Incomplete5 is + + function Get_Priv_Val return Enu_Type is + begin + return Enu_Obj; + end Get_Priv_Val; + + end Incomplete5; + + ---------------------------------------------------------------------- + protected body Incomplete6 is + + function Get_Priv_Val return Small_Int is + begin + return Num; + end Get_Priv_Val; + + end Incomplete6; + + ---------------------------------------------------------------------- + function Return_String (S : String) return String is + begin + if Report.Ident_Bool(True) = True then + return S; + end if; + + return S; + end Return_String; + +end C3A1001_0; + + --==================================================================-- + +with Report; + +with C3A1001_0; +use C3A1001_0; + +procedure C3A1001 is + + -- Discriminant value comes from default. + + Incomplete2_Obj_1 : Incomplete2; + + Incomplete4_Obj_1 : Incomplete4; + + Incomplete6_Obj_1 : Incomplete6; + + -- Discriminant value comes from explicit constraint. + + Incomplete1_Obj_1 : Incomplete1 (F); + + Incomplete5_Obj_1 : Incomplete5 (M); + + Incomplete6_Obj_2 : Incomplete6 (2); + + -- Discriminant value comes from assignment. + + Incomplete3_Obj_1 : Incomplete3 := (Disc => 6, ID => "Sentra"); + + Incomplete1_Obj_2 : Incomplete1 := (Disc => M, MInteger => 9); + + Incomplete2_Obj_2 : Incomplete2 := (Disc => 5, ID => "Buick"); + +begin + + Report.Test ("C3A1001", "Check that the full type completing a type " & + "with no discriminant part or an unknown discriminant " & + "part may have explicitly declared or inherited " & + "discriminants. Check for cases where the types are " & + "records and protected types"); + + -- Check the initial values. + + if (Incomplete2_Obj_1.Disc /= 8) or + (Incomplete2_Obj_1.ID /= "Plymouth") then + Report.Failed ("Wrong initial values for Incomplete2_Obj_1"); + end if; + + if (Incomplete4_Obj_1.Disc /= 8) or + (Incomplete4_Obj_1.ID /= "Plymouth") then + Report.Failed ("Wrong initial values for Incomplete4_Obj_1"); + end if; + + if (Incomplete6_Obj_1.Disc /= 1) or + (Incomplete6_Obj_1.Get_Priv_Val /= 1) then + Report.Failed ("Wrong initial value for Incomplete6_Obj_1"); + end if; + + -- Check the explicit values. + + if (Incomplete1_Obj_1.Disc /= F) or + (Incomplete1_Obj_1.FInteger /= 8) then + Report.Failed ("Wrong values for Incomplete1_Obj_1"); + end if; + + if (Incomplete5_Obj_1.Disc /= M) or + (Incomplete5_Obj_1.Get_Priv_Val /= M) then + Report.Failed ("Wrong value for Incomplete5_Obj_1"); + end if; + + if (Incomplete6_Obj_2.Disc /= 2) or + (Incomplete6_Obj_2.Get_Priv_Val /= 2) then + Report.Failed ("Wrong value for Incomplete6_Obj_2"); + end if; + + -- Check the assigned values. + + if (Incomplete3_Obj_1.Disc /= 6) or + (Incomplete3_Obj_1.ID /= "Sentra") then + Report.Failed ("Wrong values for Incomplete3_Obj_1"); + end if; + + if (Incomplete1_Obj_2.Disc /= M) or + (Incomplete1_Obj_2.MInteger /= 9) then + Report.Failed ("Wrong values for Incomplete1_Obj_2"); + end if; + + if (Incomplete2_Obj_2.Disc /= 5) or + (Incomplete2_Obj_2.ID /= "Buick") then + Report.Failed ("Wrong values for Incomplete2_Obj_2"); + end if; + + -- Make sure that assignments work without problems. + + Incomplete1_Obj_1.FInteger := 1; + + -- Avoid optimization (dead variable removal of FInteger): + + if Incomplete1_Obj_1.FInteger /= Report.Ident_Int(1) + then + Report.Failed ("Wrong value stored in Incomplete1_Obj_1.FInteger"); + end if; + + Incomplete2_Obj_1.ID := Return_String ("12345678"); + + -- Avoid optimization (dead variable removal of ID) + + if Incomplete2_Obj_1.ID /= Return_String ("12345678") + then + Report.Failed ("Wrong values for Incomplete8_Obj_1.ID"); + end if; + + Incomplete4_Obj_1.ID := Return_String ("87654321"); + + -- Avoid optimization (dead variable removal of ID) + + if Incomplete4_Obj_1.ID /= Return_String ("87654321") + then + Report.Failed ("Wrong values for Incomplete4_Obj_1.ID"); + end if; + + + Test1: + declare + + Incomplete8_Obj_1 : Incomplete8 (10); + + begin + Incomplete8_Obj_1.Str := "Merry Xmas"; + + -- Avoid optimization (dead variable removal of Str): + + if Return_String (Incomplete8_Obj_1.Str) /= "Merry Xmas" + then + Report.Failed ("Wrong values for Incomplete8_Obj_1.Str"); + end if; + + exception + when Constraint_Error => + Report.Failed ("Constraint_Error raised in Incomplete8_Obj_1"); + + end Test1; + + Test2: + declare + + Incomplete8_Obj_2 : Incomplete8 (5); + + begin + Incomplete8_Obj_2.Str := "Happy"; + + -- Avoid optimization (dead variable removal of Str): + + if Return_String (Incomplete8_Obj_2.Str) /= "Happy" + then + Report.Failed ("Wrong values for Incomplete8_Obj_1.Str"); + end if; + + exception + when Constraint_Error => + Report.Failed ("Constraint_Error raised in Incomplete8_Obj_2"); + + end Test2; + + Report.Result; + +end C3A1001; diff --git a/gcc-4.9/gcc/testsuite/ada/acats/tests/c3/c3a1002.a b/gcc-4.9/gcc/testsuite/ada/acats/tests/c3/c3a1002.a new file mode 100644 index 000000000..27d1f843c --- /dev/null +++ b/gcc-4.9/gcc/testsuite/ada/acats/tests/c3/c3a1002.a @@ -0,0 +1,251 @@ +-- C3A1002.A +-- +-- Grant of Unlimited Rights +-- +-- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687, +-- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained +-- unlimited rights in the software and documentation contained herein. +-- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making +-- this public release, the Government intends to confer upon all +-- recipients unlimited rights equal to those held by the Government. +-- These rights include rights to use, duplicate, release or disclose the +-- released technical data and computer software in whole or in part, in +-- any manner and for any purpose whatsoever, and to have or permit others +-- to do so. +-- +-- DISCLAIMER +-- +-- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR +-- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED +-- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE +-- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE +-- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A +-- PARTICULAR PURPOSE OF SAID MATERIAL. +--* +-- +-- OBJECTIVE: +-- Check that the full type completing a type with no discriminant part +-- or an unknown discriminant part may have explicitly declared or +-- inherited discriminants. +-- Check for cases where the types are tagged records and task types. +-- +-- TEST DESCRIPTION: +-- Declare two groups of incomplete types: one group with no discriminant +-- part and one group with unknown discriminant part. Both groups of +-- incomplete types are completed with both explicit and inherited +-- discriminants. Discriminants for task types are declared with both +-- default and non default values. Discriminants for tagged types are +-- only declared without default values. +-- In the main program, verify that objects of both groups of incomplete +-- types can be created by default values or by assignments. +-- +-- +-- CHANGE HISTORY: +-- 23 Oct 95 SAIC Initial prerelease version. +-- 19 Oct 96 SAIC ACVC 2.1: modified test description. Initialized +-- Int_Val. +-- +--! + +package C3A1002_0 is + + subtype Small_Int is Integer range 1 .. 15; + + type Enu_Type is (M, F); + + type Tag_Type is tagged + record + I : Small_Int := 1; + end record; + + type NTag_Type (D : Small_Int) is new Tag_Type with + record + S : String (1 .. D) := "Aloha"; + end record; + + type Incomplete1; -- no discriminant + + type Incomplete2 (<>); -- unknown discriminant + + type Incomplete3; -- no discriminant + + type Incomplete4 (<>); -- unknown discriminant + + type Incomplete5; -- no discriminant + + type Incomplete6 (<>); -- unknown discriminant + + type Incomplete1 (D1 : Enu_Type) is tagged -- no discriminant/ + record -- explicit discriminant + case D1 is + when M => MInteger : Small_Int := 9; + when F => FInteger : Small_Int := 8; + end case; + end record; + + type Incomplete2 (D2 : Small_Int) is new -- unknown discriminant/ + Incomplete1 (D1 => F) with record -- explicit discriminant + ID : String (1 .. D2) := "ACVC95"; + end record; + + type Incomplete3 is new -- no discriminant/ + NTag_Type with record -- inherited discriminant + E : Enu_Type := M; + end record; + + type Incomplete4 is new -- unknown discriminant/ + NTag_Type (D => 3) with record -- inherited discriminant + E : Enu_Type := F; + end record; + + task type Incomplete5 (D5 : Enu_Type) is -- no discriminant/ + entry Read_Disc (P : out Enu_Type); -- explicit discriminant + end Incomplete5; + + task type Incomplete6 + (D6 : Small_Int := 4) is -- unknown discriminant/ + entry Read_Int (P : out Small_Int); -- explicit discriminant + end Incomplete6; + +end C3A1002_0; + + --==================================================================-- + +package body C3A1002_0 is + + task body Incomplete5 is + begin + select + accept Read_Disc (P : out Enu_Type) do + P := D5; + end Read_Disc; + or + terminate; + end select; + + end Incomplete5; + + ---------------------------------------------------------------------- + task body Incomplete6 is + begin + select + accept Read_Int (P : out Small_Int) do + P := D6; + end Read_Int; + or + terminate; + end select; + + end Incomplete6; + +end C3A1002_0; + + --==================================================================-- + +with Report; + +with C3A1002_0; +use C3A1002_0; + +procedure C3A1002 is + + Enum_Val : Enu_Type := M; + + Int_Val : Small_Int := 15; + + -- Discriminant value comes from default. + + Incomplete6_Obj_1 : Incomplete6; + + -- Discriminant value comes from explicit constraint. + + Incomplete1_Obj_1 : Incomplete1 (M); + + Incomplete2_Obj_1 : Incomplete2 (6); + + Incomplete5_Obj_1 : Incomplete5 (F); + + Incomplete6_Obj_2 : Incomplete6 (7); + + -- Discriminant value comes from assignment. + + Incomplete1_Obj_2 : Incomplete1 + := (F, 12); + + Incomplete3_Obj_1 : Incomplete3 + := (D => 2, S => "Hi", I => 10, E => F); + + Incomplete4_Obj_1 : Incomplete4 + := (E => M, D => 3, S => "Bye", I => 14); + +begin + + Report.Test ("C3A1002", "Check that the full type completing a type " & + "with no discriminant part or an unknown discriminant " & + "part may have explicitly declared or inherited " & + "discriminants. Check for cases where the types are " & + "tagged records and task types"); + + -- Check the initial values. + + if (Incomplete6_Obj_1.D6 /= 4) then + Report.Failed ("Wrong initial value for Incomplete6_Obj_1"); + end if; + + -- Check the explicit values. + + if (Incomplete1_Obj_1.D1 /= M) or + (Incomplete1_Obj_1.MInteger /= 9) then + Report.Failed ("Wrong values for Incomplete1_Obj_1"); + end if; + + if (Incomplete2_Obj_1.D2 /= 6) or + (Incomplete2_Obj_1.FInteger /= 8) or + (Incomplete2_Obj_1.ID /= "ACVC95") then + Report.Failed ("Wrong values for Incomplete2_Obj_1"); + end if; + + if (Incomplete5_Obj_1.D5 /= F) then + Report.Failed ("Wrong value for Incomplete5_Obj_1"); + end if; + + Incomplete5_Obj_1.Read_Disc (Enum_Val); + + if (Enum_Val /= F) then + Report.Failed ("Wrong value for Enum_Val"); + end if; + + if (Incomplete6_Obj_2.D6 /= 7) then + Report.Failed ("Wrong value for Incomplete6_Obj_2"); + end if; + + Incomplete6_Obj_1.Read_Int (Int_Val); + + if (Int_Val /= 4) then + Report.Failed ("Wrong value for Int_Val"); + end if; + + -- Check the assigned values. + + if (Incomplete1_Obj_2.D1 /= F) or + (Incomplete1_Obj_2.FInteger /= 12) then + Report.Failed ("Wrong values for Incomplete1_Obj_2"); + end if; + + if (Incomplete3_Obj_1.D /= 2 ) or + (Incomplete3_Obj_1.I /= 10) or + (Incomplete3_Obj_1.E /= F ) or + (Incomplete3_Obj_1.S /= "Hi") then + Report.Failed ("Wrong values for Incomplete3_Obj_1"); + end if; + + if (Incomplete4_Obj_1.E /= M ) or + (Incomplete4_Obj_1.D /= 3) or + (Incomplete4_Obj_1.S /= "Bye") or + (Incomplete4_Obj_1.I /= 14) then + Report.Failed ("Wrong values for Incomplete4_Obj_1"); + end if; + + Report.Result; + +end C3A1002; diff --git a/gcc-4.9/gcc/testsuite/ada/acats/tests/c3/c3a2001.a b/gcc-4.9/gcc/testsuite/ada/acats/tests/c3/c3a2001.a new file mode 100644 index 000000000..c3c7f4410 --- /dev/null +++ b/gcc-4.9/gcc/testsuite/ada/acats/tests/c3/c3a2001.a @@ -0,0 +1,460 @@ +-- C3A2001.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 access type may be defined to designate the +-- class-wide type of an abstract type. Check that the access type +-- may then be used subsequently with types derived from the abstract +-- type. Check that dispatching operations dispatch correctly, when +-- called using values designated by objects of the access type. +-- +-- TEST DESCRIPTION: +-- This test declares an abstract type Breaker in a package, and +-- then derives from it. The type Basic_Breaker defines the least +-- possible in order to not be abstract. The type Ground_Fault is +-- defined to inherit as much as possible, whereas type Special_Breaker +-- overrides everything it can. The type Special_Breaker also includes +-- an embedded Basic_Breaker object. The main program then utilizes +-- each of the three types of breaker, and to ascertain that the +-- overloading and tagging resolution are correct, each "Create" +-- procedure is called with a unique value. The diagram below +-- illustrates the relationships. +-- +-- Abstract type: Breaker(1) +-- | +-- Basic_Breaker(2) +-- / \ +-- Ground_Fault(3) Special_Breaker(4) +-- +-- Test structure is a polymorphic linked list, modeling a circuit +-- as a list of components. The type component is the access type +-- defined to designate Breaker'Class values. The test then creates +-- some values, and traverses the list to determine correct operation. +-- This test is instrumented with a the trace facility found in +-- foundation F392C00 to simplify the verification process. +-- +-- +-- CHANGE HISTORY: +-- 06 Dec 94 SAIC ACVC 2.0 +-- 10 Nov 95 SAIC Checked compilation for ACVC 2.0.1 +-- 23 APR 96 SAIC Added pragma Elaborate_All +-- 26 NOV 96 SAIC Elaborate_Body changed to Elaborate_All +-- +--! + +with Report; +with TCTouch; +package C3A2001_1 is + + type Breaker is abstract tagged private; + type Status is ( Power_Off, Power_On, Tripped, Failed ); + + procedure Flip ( The_Breaker : in out Breaker ) is abstract; + procedure Trip ( The_Breaker : in out Breaker ) is abstract; + procedure Reset( The_Breaker : in out Breaker ) is abstract; + procedure Fail ( The_Breaker : in out Breaker ); + + procedure Set ( The_Breaker : in out Breaker'Class; To_State : Status ); + + function Status_Of( The_Breaker : Breaker ) return Status; + +private + type Breaker is abstract tagged record + State : Status := Power_Off; + end record; +end C3A2001_1; + +---------------------------------------------------------------------------- + +with TCTouch; +package body C3A2001_1 is + procedure Fail( The_Breaker : in out Breaker ) is + begin + TCTouch.Touch( 'a' ); --------------------------------------------- a + The_Breaker.State := Failed; + end Fail; + + procedure Set( The_Breaker : in out Breaker'Class; To_State : Status ) is + begin + The_Breaker.State := To_State; + end Set; + + function Status_Of( The_Breaker : Breaker ) return Status is + begin + TCTouch.Touch( 'b' ); --------------------------------------------- b + return The_Breaker.State; + end Status_Of; +end C3A2001_1; + +---------------------------------------------------------------------------- + +with C3A2001_1; +package C3A2001_2 is + + type Basic_Breaker is new C3A2001_1.Breaker with private; + + type Voltages is ( V12, V110, V220, V440 ); + type Amps is ( A1, A5, A10, A25, A100 ); + + function Construct( Voltage : Voltages; Amperage : Amps ) + return Basic_Breaker; + + procedure Flip ( The_Breaker : in out Basic_Breaker ); + procedure Trip ( The_Breaker : in out Basic_Breaker ); + procedure Reset( The_Breaker : in out Basic_Breaker ); +private + type Basic_Breaker is new C3A2001_1.Breaker with record + Voltage_Level : Voltages := V110; + Amperage : Amps; + end record; +end C3A2001_2; + +---------------------------------------------------------------------------- + +with TCTouch; +package body C3A2001_2 is + function Construct( Voltage : Voltages; Amperage : Amps ) + return Basic_Breaker is + It : Basic_Breaker; + begin + TCTouch.Touch( 'c' ); --------------------------------------------- c + It.Amperage := Amperage; + It.Voltage_Level := Voltage; + C3A2001_1.Set( It, C3A2001_1.Power_Off ); + return It; + end Construct; + + procedure Flip ( The_Breaker : in out Basic_Breaker ) is + begin + TCTouch.Touch( 'd' ); --------------------------------------------- d + case Status_Of( The_Breaker ) is + when C3A2001_1.Power_Off => + C3A2001_1.Set( The_Breaker, C3A2001_1.Power_On ); + when C3A2001_1.Power_On => + C3A2001_1.Set( The_Breaker, C3A2001_1.Power_Off ); + when C3A2001_1.Tripped | C3A2001_1.Failed => null; + end case; + end Flip; + + procedure Trip ( The_Breaker : in out Basic_Breaker ) is + begin + TCTouch.Touch( 'e' ); --------------------------------------------- e + C3A2001_1.Set( The_Breaker, C3A2001_1.Tripped ); + end Trip; + + procedure Reset( The_Breaker : in out Basic_Breaker ) is + begin + TCTouch.Touch( 'f' ); --------------------------------------------- f + case Status_Of( The_Breaker ) is + when C3A2001_1.Power_Off | C3A2001_1.Tripped => + C3A2001_1.Set( The_Breaker, C3A2001_1.Power_On ); + when C3A2001_1.Power_On | C3A2001_1.Failed => null; + end case; + end Reset; + +end C3A2001_2; + +---------------------------------------------------------------------------- + +with C3A2001_1,C3A2001_2; +package C3A2001_3 is + use type C3A2001_1.Status; + + type Ground_Fault is new C3A2001_2.Basic_Breaker with private; + + function Construct( Voltage : C3A2001_2.Voltages; + Amperage : C3A2001_2.Amps ) + return Ground_Fault; + + procedure Set_Trip( The_Breaker : in out Ground_Fault; + Capacitance : in Integer ); + +private + type Ground_Fault is new C3A2001_2.Basic_Breaker with record + Capacitance : Integer; + end record; +end C3A2001_3; + +---------------------------------------------------------------------------- + +with TCTouch; +package body C3A2001_3 is + + function Construct( Voltage : C3A2001_2.Voltages; + Amperage : C3A2001_2.Amps ) + return Ground_Fault is + begin + TCTouch.Touch( 'g' ); --------------------------------------------- g + return ( C3A2001_2.Construct( Voltage, Amperage ) + with Capacitance => 0 ); + end Construct; + + + procedure Set_Trip( The_Breaker : in out Ground_Fault; + Capacitance : in Integer ) is + begin + TCTouch.Touch( 'h' ); --------------------------------------------- h + The_Breaker.Capacitance := Capacitance; + end Set_Trip; + +end C3A2001_3; + +---------------------------------------------------------------------------- + +with C3A2001_1, C3A2001_2; +package C3A2001_4 is + + type Special_Breaker is new C3A2001_2.Basic_Breaker with private; + + function Construct( Voltage : C3A2001_2.Voltages; + Amperage : C3A2001_2.Amps ) + return Special_Breaker; + + procedure Flip ( The_Breaker : in out Special_Breaker ); + procedure Trip ( The_Breaker : in out Special_Breaker ); + procedure Reset( The_Breaker : in out Special_Breaker ); + procedure Fail ( The_Breaker : in out Special_Breaker ); + + function Status_Of( The_Breaker : Special_Breaker ) return C3A2001_1.Status; + function On_Backup( The_Breaker : Special_Breaker ) return Boolean; + +private + type Special_Breaker is new C3A2001_2.Basic_Breaker with record + Backup : C3A2001_2.Basic_Breaker; + end record; +end C3A2001_4; + +---------------------------------------------------------------------------- + +with TCTouch; +package body C3A2001_4 is + + function Construct( Voltage : C3A2001_2.Voltages; + Amperage : C3A2001_2.Amps ) + return Special_Breaker is + It: Special_Breaker; + procedure Set_Root( It: in out C3A2001_2.Basic_Breaker ) is + begin + It := C3A2001_2.Construct( Voltage, Amperage ); + end Set_Root; + begin + TCTouch.Touch( 'i' ); --------------------------------------------- i + Set_Root( C3A2001_2.Basic_Breaker( It ) ); + Set_Root( It.Backup ); + return It; + end Construct; + + function Status_Of( It: C3A2001_1.Breaker ) return C3A2001_1.Status + renames C3A2001_1.Status_Of; + + procedure Flip ( The_Breaker : in out Special_Breaker ) is + begin + TCTouch.Touch( 'j' ); --------------------------------------------- j + case Status_Of( C3A2001_1.Breaker( The_Breaker )) is + when C3A2001_1.Power_Off | C3A2001_1.Power_On => + C3A2001_2.Flip( C3A2001_2.Basic_Breaker( The_Breaker ) ); + when others => + C3A2001_2.Flip( The_Breaker.Backup ); + end case; + end Flip; + + procedure Trip ( The_Breaker : in out Special_Breaker ) is + begin + TCTouch.Touch( 'k' ); --------------------------------------------- k + case Status_Of( C3A2001_1.Breaker( The_Breaker )) is + when C3A2001_1.Power_Off => null; + when C3A2001_1.Power_On => + C3A2001_2.Reset( The_Breaker.Backup ); + C3A2001_2.Trip( C3A2001_2.Basic_Breaker( The_Breaker ) ); + when others => + C3A2001_2.Trip( The_Breaker.Backup ); + end case; + end Trip; + + procedure Reset( The_Breaker : in out Special_Breaker ) is + begin + TCTouch.Touch( 'l' ); --------------------------------------------- l + case Status_Of( C3A2001_1.Breaker( The_Breaker )) is + when C3A2001_1.Tripped => + C3A2001_2.Reset( C3A2001_2.Basic_Breaker( The_Breaker )); + when C3A2001_1.Failed => + C3A2001_2.Reset( The_Breaker.Backup ); + when C3A2001_1.Power_On | C3A2001_1.Power_Off => + null; + end case; + end Reset; + + procedure Fail ( The_Breaker : in out Special_Breaker ) is + begin + TCTouch.Touch( 'm' ); --------------------------------------------- m + case Status_Of( C3A2001_1.Breaker( The_Breaker )) is + when C3A2001_1.Failed => + C3A2001_2.Fail( The_Breaker.Backup ); + when others => + C3A2001_2.Fail( C3A2001_2.Basic_Breaker( The_Breaker )); + C3A2001_2.Reset( The_Breaker.Backup ); + end case; + end Fail; + + function Status_Of( The_Breaker : Special_Breaker ) + return C3A2001_1.Status is + begin + TCTouch.Touch( 'n' ); --------------------------------------------- n + case Status_Of( C3A2001_1.Breaker( The_Breaker )) is + when C3A2001_1.Power_On => return C3A2001_1.Power_On; + when C3A2001_1.Power_Off => return C3A2001_1.Power_Off; + when others => + return C3A2001_2.Status_Of( The_Breaker.Backup ); + end case; + end Status_Of; + + function On_Backup( The_Breaker : Special_Breaker ) return Boolean is + use C3A2001_2; + use type C3A2001_1.Status; + begin + return Status_Of(Basic_Breaker(The_Breaker)) = C3A2001_1.Tripped + or Status_Of(Basic_Breaker(The_Breaker)) = C3A2001_1.Failed; + end On_Backup; + +end C3A2001_4; + +---------------------------------------------------------------------------- + +with C3A2001_1; +package C3A2001_5 is + + type Component is access C3A2001_1.Breaker'Class; + + type Circuit; + type Connection is access Circuit; + + type Circuit is record + The_Gadget : Component; + Next : Connection; + end record; + + procedure Flipper( The_Circuit : Connection ); + procedure Tripper( The_Circuit : Connection ); + procedure Restore( The_Circuit : Connection ); + procedure Failure( The_Circuit : Connection ); + + Short : Connection := null; + +end C3A2001_5; + +---------------------------------------------------------------------------- +with Report; +with TCTouch; +with C3A2001_1, C3A2001_2, C3A2001_3, C3A2001_4; + +pragma Elaborate_All( Report, TCTouch, + C3A2001_1, C3A2001_2, C3A2001_3, C3A2001_4 ); + +package body C3A2001_5 is + + function Neww( Breaker: in C3A2001_1.Breaker'Class ) + return Component is + begin + return new C3A2001_1.Breaker'Class'( Breaker ); + end Neww; + + procedure Add( Gadget : in Component; + To_Circuit : in out Connection) is + begin + To_Circuit := new Circuit'(Gadget,To_Circuit); + end Add; + + procedure Flipper( The_Circuit : Connection ) is + Probe : Connection := The_Circuit; + begin + while Probe /= null loop + C3A2001_1.Flip( Probe.The_Gadget.all ); + Probe := Probe.Next; + end loop; + end Flipper; + + procedure Tripper( The_Circuit : Connection ) is + Probe : Connection := The_Circuit; + begin + while Probe /= null loop + C3A2001_1.Trip( Probe.The_Gadget.all ); + Probe := Probe.Next; + end loop; + end Tripper; + + procedure Restore( The_Circuit : Connection ) is + Probe : Connection := The_Circuit; + begin + while Probe /= null loop + C3A2001_1.Reset( Probe.The_Gadget.all ); + Probe := Probe.Next; + end loop; + end Restore; + + procedure Failure( The_Circuit : Connection ) is + Probe : Connection := The_Circuit; + begin + while Probe /= null loop + C3A2001_1.Fail( Probe.The_Gadget.all ); + Probe := Probe.Next; + end loop; + end Failure; + +begin + Add( Neww( C3A2001_2.Construct( C3A2001_2.V440, C3A2001_2.A5 )), Short ); + Add( Neww( C3A2001_3.Construct( C3A2001_2.V110, C3A2001_2.A1 )), Short ); + Add( Neww( C3A2001_4.Construct( C3A2001_2.V12, C3A2001_2.A100 )), Short ); +end C3A2001_5; + +---------------------------------------------------------------------------- + +with Report; +with TCTouch; +with C3A2001_5; +procedure C3A2001 is + +begin -- Main test procedure. + + Report.Test ("C3A2001", "Check that an abstract type can be declared " & + "and used. Check actual subprograms dispatch correctly" ); + + -- This Validate call must be _after_ the call to Report.Test + TCTouch.Validate( "cgcicc", "Adding" ); + + C3A2001_5.Flipper( C3A2001_5.Short ); + TCTouch.Validate( "jbdbdbdb", "Flipping" ); + + C3A2001_5.Tripper( C3A2001_5.Short ); + TCTouch.Validate( "kbfbeee", "Tripping" ); + + C3A2001_5.Restore( C3A2001_5.Short ); + TCTouch.Validate( "lbfbfbfb", "Restoring" ); + + C3A2001_5.Failure( C3A2001_5.Short ); + TCTouch.Validate( "mbafbaa", "Circuits Failing" ); + + Report.Result; + +end C3A2001; diff --git a/gcc-4.9/gcc/testsuite/ada/acats/tests/c3/c3a2002.a b/gcc-4.9/gcc/testsuite/ada/acats/tests/c3/c3a2002.a new file mode 100644 index 000000000..63ea7008b --- /dev/null +++ b/gcc-4.9/gcc/testsuite/ada/acats/tests/c3/c3a2002.a @@ -0,0 +1,295 @@ +-- C3A2002.A +-- +-- Grant of Unlimited Rights +-- +-- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687, +-- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained +-- unlimited rights in the software and documentation contained herein. +-- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making +-- this public release, the Government intends to confer upon all +-- recipients unlimited rights equal to those held by the Government. +-- These rights include rights to use, duplicate, release or disclose the +-- released technical data and computer software in whole or in part, in +-- any manner and for any purpose whatsoever, and to have or permit others +-- to do so. +-- +-- DISCLAIMER +-- +-- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR +-- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED +-- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE +-- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE +-- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A +-- PARTICULAR PURPOSE OF SAID MATERIAL. +--* +-- +-- OBJECTIVE: +-- Check that, for X'Access of a general access type A, Program_Error is +-- raised if the accessibility level of X is deeper than that of A. +-- Check for the case where X denotes a view that is a dereference of an +-- access parameter, or a rename thereof. +-- +-- Check for cases where the actual corresponding to X is: +-- (a) An allocator. +-- (b) An expression of a named access type. +-- (c) Obj'Access. +-- +-- TEST DESCRIPTION: +-- In order to satisfy accessibility requirements, the designated +-- object X must be at the same or a less deep nesting level than the +-- general access type A -- X must "live" as long as A. Nesting +-- levels are the run-time nestings of masters: block statements; +-- subprogram, task, and entry bodies; and accept statements. Packages +-- are invisible to accessibility rules. +-- +-- This test declares subprograms with access parameters, within which +-- 'Access is attempted on a dereference of the access parameter, and +-- assigned to an access object whose type A is declared at some nesting +-- level. The test verifies that Program_Error is raised if the actual +-- corresponding to the access parameter is: +-- +-- (1) an allocator, and the accessibility level of the execution +-- of the called subprogram is deeper than that of the access +-- type A. +-- +-- (2) an expression of a named access type, and the accessibility +-- level of the named access type is deeper than that of the +-- access type A. +-- +-- (3) a reference to the Access attribute (e.g., X'Access), and +-- the accessibility level of X is deeper than that of the +-- access type A. +-- +-- Note that the static nesting level of the actual corresponding to the +-- access parameter can be deeper than that of the type A -- it is +-- the run-time nesting that matters for accessibility rules. Consider +-- the case where the access type A is declared within the called +-- subprogram. The accessibility check will never fail, even if the +-- actual happens to have a deeper static nesting level: +-- +-- procedure P (X: access T) is +-- type A is access all T; -- Static level = 2, e.g. +-- Acc : A := X.all'Access; -- Check should never fail. +-- begin null; end; +-- . . . +-- declare +-- Actual : aliased T; -- Static level = 3, e.g. +-- begin +-- P (Actual'Access); +-- end; +-- +-- For the execution of P, the accessibility level of type A will +-- always be deeper than that of Actual, so there is no danger of a +-- dangling reference arising from the assignment to Acc. Thus, +-- X.all'Access is safe, even though the static nesting level of +-- Actual is deeper than that of A. +-- +-- +-- CHANGE HISTORY: +-- 06 Dec 94 SAIC ACVC 2.0 +-- +--! + +package C3A2002_0 is + + type Desig is array (1 .. 10) of Integer; + + X0 : aliased Desig; -- Level = 0. + + type Acc_L0 is access all Desig; -- Level = 0. + A0 : Acc_L0; + + type Result_Kind is (OK, P_E, O_E); + + procedure A_Is_Level_0 (X: access Desig; R : out Result_Kind); + procedure Never_Fails (X: access Desig; R : out Result_Kind); + +end C3A2002_0; + + + --==================================================================-- + +package body C3A2002_0 is + + procedure A_Is_Level_0 (X : access Desig; + R : out Result_Kind) is + begin + -- The accessibility level of the type of A0 is 0. + A0 := X.all'Access; + R := OK; + exception + when Program_Error => + R := P_E; + when others => + R := O_E; + end A_Is_Level_0; + + ----------------------------------------------- + procedure Never_Fails (X: access Desig; + R : out Result_Kind) is + type Acc_Local is access all Desig; + AL : Acc_Local; + begin + -- X.all'Access below will always be safe, since the accessibility + -- level (although not necessarily the static nesting depth) of the + -- type of AL will always be deeper than or the same as that of the + -- actual corresponding to Y. + AL := X.all'Access; + R := OK; + exception + when Program_Error => + R := P_E; + when others => + R := O_E; + end Never_Fails; + +end C3A2002_0; + + + --==================================================================-- + + +with C3A2002_0; +with Report; + +procedure C3A2002 is + + X1 : aliased C3A2002_0.Desig; -- Level = 1. + + type Acc_L1 is access all C3A2002_0.Desig; -- Level = 1. + A1 : Acc_L1; + + Expr_L0 : C3A2002_0.Acc_L0 := C3A2002_0.X0'Access; + Expr_L1 : Acc_L1 := X1'Access; + + Res : C3A2002_0.Result_Kind; + + use type C3A2002_0.Result_Kind; + + ----------------------------------------------- + procedure A_Is_Level_1 (X : access C3A2002_0.Desig; + R : out C3A2002_0.Result_Kind) is + -- Dereference of an access_to_object value is aliased. + Ren : C3A2002_0.Desig renames X.all; -- Renaming of a dereference + begin -- of an access parameter. + -- The accessibility level of the type of A1 is 1. + A1 := Ren'Access; + R := C3A2002_0.OK; + exception + when Program_Error => + R := C3A2002_0.P_E; + when others => + R := C3A2002_0.O_E; + end A_Is_Level_1; + + ----------------------------------------------- + procedure Display_Results (Result : in C3A2002_0.Result_Kind; + Expected: in C3A2002_0.Result_Kind; + Message : in String) is + begin + if Result /= Expected then + case Result is + when C3A2002_0.OK => Report.Failed ("No exception raised: " & + Message); + when C3A2002_0.P_E => Report.Failed ("Program_Error raised: " & + Message); + when C3A2002_0.O_E => Report.Failed ("Unexpected exception " & + "raised: " & Message); + end case; + end if; + end Display_Results; + +begin -- C3A2002 + + Report.Test ("C3A2002", "Check that, for X'Access of general access " & + "type A, Program_Error is raised if the accessibility " & + "level of X is deeper than that of A: X is an access " & + "parameter; corresponding actual is an allocator, " & + "expression of a named access type, Obj'Access, or a " & + "rename thereof"); + + + -- Actual is X'Access: + + C3A2002_0.Never_Fails (C3A2002_0.X0'Access, Res); + Display_Results (Res, C3A2002_0.OK, "X0'Access, local access type"); + + C3A2002_0.A_Is_Level_0 (C3A2002_0.X0'Access, Res); + Display_Results (Res, C3A2002_0.OK, "X0'Access, level 0 access type"); + + C3A2002_0.A_Is_Level_0 (X1'Access, Res); + Display_Results (Res, C3A2002_0.P_E, "X1'Access, level 0 access type"); + + A_Is_Level_1 (X1'Access, Res); + Display_Results (Res, C3A2002_0.OK, "X1'Access, level 1 access type"); + + + -- Actual is expression of a named access type: + + C3A2002_0.Never_Fails (Expr_L1, Res); + Display_Results (Res, C3A2002_0.OK, "Expr_L1, local access type"); + + C3A2002_0.A_Is_Level_0 (Expr_L1, Res); + Display_Results (Res, C3A2002_0.P_E, "Expr_L1, level 0 access type"); + + A_Is_Level_1 (Expr_L0, Res); + Display_Results (Res, C3A2002_0.OK, "Expr_L0, level 1 access type"); + + A_Is_Level_1 (Expr_L1, Res); + Display_Results (Res, C3A2002_0.OK, "Expr_L1, level 1 access type"); + + -- Actual is allocator (level of execution = 2): + + C3A2002_0.Never_Fails (new C3A2002_0.Desig, Res); + Display_Results (Res, C3A2002_0.OK, "Allocator level 2, " & + "local access type"); + + -- Since actual is an allocator, its accessibility level is that of + -- the execution of the called subprogram, i.e., level 2. + + C3A2002_0.A_Is_Level_0 (new C3A2002_0.Desig, Res); + Display_Results (Res, C3A2002_0.P_E, "Allocator level 2, " & + "level 0 access type"); + + A_Is_Level_1 (new C3A2002_0.Desig, Res); + Display_Results (Res, C3A2002_0.P_E, "Allocator level 2, " & + "level 1 access type"); + + + Block_L2: + declare + X2 : aliased C3A2002_0.Desig; -- Level = 2. + type Acc_L2 is access all C3A2002_0.Desig; -- Level = 2. + Expr_L2 : Acc_L2 := X1'Access; + begin + + -- Actual is X'Access: + + C3A2002_0.Never_Fails (X2'Access, Res); + Display_Results (Res, C3A2002_0.OK, "X2'Access, local access type"); + + C3A2002_0.A_Is_Level_0 (X2'Access, Res); + Display_Results (Res, C3A2002_0.P_E, "X2'Access, level 0 access type"); + + + -- Actual is expression of a named access type: + + A_Is_Level_1 (Expr_L2, Res); + Display_Results (Res, C3A2002_0.P_E, "Expr_L2, level 1 access type"); + + + -- Actual is allocator (level of execution = 3): + + C3A2002_0.Never_Fails (new C3A2002_0.Desig, Res); + Display_Results (Res, C3A2002_0.OK, "Allocator level 3, " & + "local access type"); + + A_Is_Level_1 (new C3A2002_0.Desig, Res); + Display_Results (Res, C3A2002_0.P_E, "Allocator level 3, " & + "level 1 access type"); + + end Block_L2; + + Report.Result; + +end C3A2002; diff --git a/gcc-4.9/gcc/testsuite/ada/acats/tests/c3/c3a2003.a b/gcc-4.9/gcc/testsuite/ada/acats/tests/c3/c3a2003.a new file mode 100644 index 000000000..deb92f1a8 --- /dev/null +++ b/gcc-4.9/gcc/testsuite/ada/acats/tests/c3/c3a2003.a @@ -0,0 +1,329 @@ +-- C3A2003.A +-- +-- Grant of Unlimited Rights +-- +-- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687, +-- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained +-- unlimited rights in the software and documentation contained herein. +-- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making +-- this public release, the Government intends to confer upon all +-- recipients unlimited rights equal to those held by the Government. +-- These rights include rights to use, duplicate, release or disclose the +-- released technical data and computer software in whole or in part, in +-- any manner and for any purpose whatsoever, and to have or permit others +-- to do so. +-- +-- DISCLAIMER +-- +-- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR +-- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED +-- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE +-- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE +-- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A +-- PARTICULAR PURPOSE OF SAID MATERIAL. +--* +-- +-- OBJECTIVE: +-- Check that, for X'Access of a general access type A, Program_Error is +-- raised if the accessibility level of X is deeper than that of A. +-- Check for the case where X denotes a view that is a dereference of an +-- access parameter, or a rename thereof. Check for the case where X is +-- an access parameter and the corresponding actual is another access +-- parameter. +-- +-- TEST DESCRIPTION: +-- In order to satisfy accessibility requirements, the designated +-- object X must be at the same or a less deep nesting level than the +-- general access type A -- X must "live" as long as A. Nesting +-- levels are the run-time nestings of masters: block statements; +-- subprogram, task, and entry bodies; and accept statements. Packages +-- are invisible to accessibility rules. +-- +-- This test declares subprograms with access parameters, within which +-- 'Access is attempted on a dereference of an access parameter, and +-- assigned to an access object whose type A is declared at some nesting +-- level. The test verifies that Program_Error is raised if the actual +-- corresponding to the access parameter is another access parameter, +-- and the actual corresponding to this second access parameter is: +-- +-- (1) an expression of a named access type, and the accessibility +-- level of the named access type is deeper than that of the +-- access type A. +-- +-- (2) a reference to the Access attribute (e.g., X'Access), and +-- the accessibility level of X is deeper than that of the +-- access type A. +-- +-- Note that the static nesting level of the actual corresponding to the +-- access parameter can be deeper than that of the type A -- it is +-- the run-time nesting that matters for accessibility rules. Consider +-- the case where the access type A is declared within the called +-- subprogram. The accessibility check will never fail, even if the +-- actual happens to have a deeper static nesting level: +-- +-- procedure P (X: access T) is +-- type A is access all T; -- Static level = 2, e.g. +-- Acc : A := X.all'Access; -- Check should never fail. +-- begin null; end; +-- . . . +-- procedure Q (Y: access T) is +-- begin +-- P(Y); +-- end; +-- . . . +-- declare +-- Actual : aliased T; -- Static level = 3, e.g. +-- begin +-- Q (Actual'Access); +-- end; +-- +-- For the execution of Q (and hence P), the accessibility level of +-- type A will always be deeper than that of Actual, so there is no +-- danger of a dangling reference arising from the assignment to +-- Acc. Thus, X.all'Access is safe, even though the static nesting +-- level of Actual is deeper than that of A. +-- +-- +-- CHANGE HISTORY: +-- 06 Dec 94 SAIC ACVC 2.0 +-- 15 Jul 98 EDS Avoid optimization. +-- 28 Jun 02 RLB Added pragma Elaborate_All (Report);. +--! + +with report; use report; pragma Elaborate_All (report); +package C3A2003_0 is + + type Desig is array (1 .. 10) of Integer; + + X0 : aliased Desig := (Desig'Range => Ident_Int(3)); -- Level = 0. + + type Acc_L0 is access all Desig; -- Level = 0. + A0 : Acc_L0; + + type Result_Kind is (OK, P_E, O_E); + + procedure Target_Is_Level_0_Nest (Y: access Desig; S: out Result_Kind); + procedure Never_Fails_Nest (Y: access Desig; S: out Result_Kind); + procedure Never_Fails_Same (Y: access Desig; S: out Result_Kind); + +end C3A2003_0; + + + --==================================================================-- + + +package body C3A2003_0 is + + procedure Target_Is_Level_0_Nest (Y: access Desig; S: out Result_Kind) is + + + -- This procedure utilizes 'Access on a dereference of an access + -- parameter, and assigned to an access object whose type A is + -- declared at some nesting level. Program_Error is raised if + -- the accessibility level of the operand type is deeper than that + -- of the target type. + + procedure Nested (X: access Desig; R: out Result_Kind) is + -- Dereference of an access_to_object value is aliased. + Ren : Desig renames X.all; -- Renaming of a dereference + begin -- of an access parameter. + -- The accessibility level of type A0 is 0. + A0 := Ren'Access; + R := OK; + exception + when Program_Error => + R := P_E; + when others => + R := O_E; + end Nested; + + begin -- Target_Is_Level_0_Nest + Nested (Y, S); + end Target_Is_Level_0_Nest; + + ------------------------------------------------------------------ + + procedure Never_Fails_Nest (Y: access Desig; S: out Result_Kind) is + + type Acc_Deeper is access all Desig; + AD : Acc_Deeper; + + function Nested (X: access Desig) return Result_Kind is + begin + -- X.all'Access below will always be safe, since the accessibility + -- level (although not necessarily the static nesting depth) of the + -- type of AD will always be deeper than or the same as that of the + -- actual corresponding to Y. + AD := X.all'Access; + if Ident_Int (AD(4)) /= 3 then --Avoid Optimization of AD + FAILED ("Initial Values not correct."); + end if; + return OK; + exception + when Program_Error => + return P_E; + when others => + return O_E; + end Nested; + + begin -- Never_Fails_Nest + S := Nested (Y); + end Never_Fails_Nest; + + ------------------------------------------------------------------ + + procedure Called_By_Never_Fails_Same + (X: access Desig; R: out Result_Kind) is + type Acc_Local is access all Desig; + AL : Acc_Local; + + -- Dereference of an access_to_object value is aliased. + Ren : Desig renames X.all; -- Renaming of a dereference + begin -- of an access parameter. + -- Ren'Access below will always be safe, since the accessibility + -- level (although not necessarily the static nesting depth) of + -- type of AL will always be deeper than or the same as that of the + -- actual corresponding to Y. + AL := Ren'Access; + if Ident_Int (AL(4)) /= 3 then --Avoid Optimization of AL + FAILED ("Initial Values not correct."); + end if; + R := OK; + exception + when Program_Error => + R := P_E; + when others => + R := O_E; + end Called_By_Never_Fails_Same; + + ------------------------------------------------------------------ + + procedure Never_Fails_Same (Y: access Desig; S: out Result_Kind) is + begin + Called_By_Never_Fails_Same (Y, S); + end Never_Fails_Same; + +end C3A2003_0; + + + --==================================================================-- + + +with C3A2003_0; +use C3A2003_0; + +with Report; use report; + +procedure C3A2003 is + + type Acc_L1 is access all Desig; -- Level = 1. + A1 : Acc_L1; + X1 : aliased Desig := (Desig'Range => Ident_Int(3)); + Res : Result_Kind; + + + procedure Called_By_Target_L1 (X: access Desig; R: out Result_Kind) is + begin + -- The accessibility level of the type of A1 is 1. + A1 := X.all'Access; + if IDENT_INT (A1(4)) /= 3 then --Avoid optimization of A1 + FAILED ("Initial values not correct."); + end if; + R := OK; + exception + when Program_Error => + R := P_E; + when others => + R := O_E; + end Called_By_Target_L1; + + ------------------------------------------------------------------ + + function Target_Is_Level_1_Same (Y: access Desig) return Result_Kind is + S : Result_Kind; + begin + Called_By_Target_L1 (Y, S); + return S; + end Target_Is_Level_1_Same; + + ------------------------------------------------------------------ + + procedure Display_Results (Result : in Result_Kind; + Expected: in Result_Kind; + Msg : in String) is + begin + if Result /= Expected then + case Result is + when OK => Report.Failed ("No exception raised: " & Msg); + when P_E => Report.Failed ("Program_Error raised: " & Msg); + when O_E => Report.Failed ("Unexpected exception raised: " & Msg); + end case; + end if; + end Display_Results; + +begin -- C3A2003 + + Report.Test ("C3A2003", "Check that, for X'Access of general access " & + "type A, Program_Error is raised if the accessibility " & + "level of X is deeper than that of A: X is an access " & + "parameter; corresponding actual is another access " & + "parameter"); + + + -- Accessibility level of actual is 0 (actual is X'Access): + + Never_Fails_Same (X0'Access, Res); + Display_Results (Res, OK, "Never_Fails_Same, level 0 actual"); + + Never_Fails_Nest (X0'Access, Res); + Display_Results (Res, OK, "Target_L1_Nest, level 0 actual"); + + Target_Is_Level_0_Nest (X0'Access, Res); + Display_Results (Res, OK, "Target_L0_Nest, level 0 actual"); + + Res := Target_Is_Level_1_Same (X0'Access); + Display_Results (Res, OK, "Target_L1_Same, level 0 actual"); + + + -- Accessibility level of actual is 1 (actual is X'Access): + + Never_Fails_Same (X1'Access, Res); + Display_Results (Res, OK, "Never_Fails_Same, level 1 actual"); + + Never_Fails_Nest (X1'Access, Res); + Display_Results (Res, OK, "Target_L1_Nest, level 1 actual"); + + Target_Is_Level_0_Nest (X1'Access, Res); + Display_Results (Res, P_E, "Target_L0_Nest, level 1 actual"); + + Res := Target_Is_Level_1_Same (X1'Access); + Display_Results (Res, OK, "Target_L1_Same, level 1 actual"); + + + Block_L2: + declare + X2 : aliased Desig := (Desig'Range => Ident_Int(3)); + type Acc_L2 is access all Desig; -- Level = 2. + Expr_L2 : Acc_L2 := X2'Access; + begin + + -- Accessibility level of actual is 2 (actual is expression of named + -- access type): + + Never_Fails_Same (Expr_L2, Res); + Display_Results (Res, OK, "Never_Fails_Same, level 2 actual"); + + Never_Fails_Nest (Expr_L2, Res); + Display_Results (Res, OK, "Target_L1_Nest, level 2 actual"); + + Target_Is_Level_0_Nest (Expr_L2, Res); + Display_Results (Res, P_E, "Target_L0_Nest, level 2 actual"); + + Res := Target_Is_Level_1_Same (Expr_L2); + Display_Results (Res, P_E, "Target_L1_Same, level 2 actual"); + + end Block_L2; + + Report.Result; + +end C3A2003; diff --git a/gcc-4.9/gcc/testsuite/ada/acats/tests/c3/c3a2a01.a b/gcc-4.9/gcc/testsuite/ada/acats/tests/c3/c3a2a01.a new file mode 100644 index 000000000..8271d4869 --- /dev/null +++ b/gcc-4.9/gcc/testsuite/ada/acats/tests/c3/c3a2a01.a @@ -0,0 +1,367 @@ +-- C3A2A01.A +-- +-- Grant of Unlimited Rights +-- +-- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687, +-- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained +-- unlimited rights in the software and documentation contained herein. +-- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making +-- this public release, the Government intends to confer upon all +-- recipients unlimited rights equal to those held by the Government. +-- These rights include rights to use, duplicate, release or disclose the +-- released technical data and computer software in whole or in part, in +-- any manner and for any purpose whatsoever, and to have or permit others +-- to do so. +-- +-- DISCLAIMER +-- +-- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR +-- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED +-- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE +-- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE +-- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A +-- PARTICULAR PURPOSE OF SAID MATERIAL. +--* +-- +-- OBJECTIVE: +-- Check that, for X'Access of a general access type A, Program_Error is +-- raised if the accessibility level of X is deeper than that of A. +-- Check for cases where X'Access occurs in an instance body, and A +-- is passed as an actual during instantiation. +-- +-- TEST DESCRIPTION: +-- In order to satisfy accessibility requirements, the designated +-- object X must be at the same or a less deep nesting level than the +-- general access type A -- X must "live" as long as A. Nesting +-- levels are the run-time nestings of masters: block statements; +-- subprogram, task, and entry bodies; and accept statements. Packages +-- are invisible to accessibility rules. +-- +-- This test declares three generic units, each of which has a formal +-- general access type: +-- +-- (1) A generic package, in which X is declared in the specification, +-- and X'Access occurs within the declarative part of the body. +-- +-- (2) A generic package, in which X is a formal in out object of a +-- tagged formal derived type, and X'Access occurs in the sequence +-- of statements of a nested subprogram. +-- +-- (3) A generic procedure, in which X is a dereference of an access +-- parameter, and X'Access occurs in the sequence of statements. +-- +-- The test verifies the following: +-- +-- For (1), Program_Error is raised upon instantiation if the generic +-- package is instantiated at a deeper level than that of the general +-- access type passed as an actual. The exception is propagated to the +-- innermost enclosing master. +-- +-- For (2), Program_Error is raised when the nested subprogram is +-- called if the object passed as an actual during instantiation of +-- the generic package has an accessibility level deeper than that of +-- the general access type passed as an actual. The exception is +-- handled within the nested subprogram. Also, check that +-- Program_Error is not raised if the level of the actual access type +-- is deeper than that of the actual object. +-- +-- For (3), Program_Error is raised when the instance subprogram is +-- called if the object pointed to by the actual corresponding to +-- the access parameter has an accessibility level deeper than that of +-- the general access type passed as an actual during instantiation. +-- The exception is handled within the instance subprogram. Also, +-- check that Program_Error is not raised if the level of the actual +-- access type is deeper than that of the actual corresponding to the +-- access parameter. +-- +-- TEST FILES: +-- The following files comprise this test: +-- +-- F3A2A00.A +-- -> C3A2A01.A +-- +-- +-- CHANGE HISTORY: +-- 12 May 95 SAIC Initial prerelease version. +-- 10 Jul 95 SAIC Modified code to avoid dead variable optimization. +-- +--! + +with F3A2A00; +generic + type FD is new F3A2A00.Array_Type; + type FAF is access all FD; +package C3A2A01_0 is + X : aliased FD; + + procedure Dummy; -- Needed to allow package body. +end C3A2A01_0; + + + --==================================================================-- + + +with Report; +package body C3A2A01_0 is + Ptr : FAF := X'Access; + Index : Integer := F3A2A00.Array_Type'First; + + procedure Dummy is + begin + null; + end Dummy; +begin + -- Avoid optimization (dead variable removal of Ptr): + + if not Report.Equal (Ptr(Index).C, Ptr(Index).C) then -- Always false. + Report.Failed ("Unexpected error in C3A2A01_0 instance"); + end if; +end C3A2A01_0; + + + --==================================================================-- + + +with F3A2A00; +generic + type FD is new F3A2A00.Tagged_Type with private; + type FAF is access all FD; + FObj : in out FD; +package C3A2A01_1 is + procedure Handle (R: out F3A2A00.TC_Result_Kind); +end C3A2A01_1; + + + --==================================================================-- + + +with Report; +package body C3A2A01_1 is + + procedure Handle (R: out F3A2A00.TC_Result_Kind) is + Ptr : FAF; + begin + Ptr := FObj'Access; + R := F3A2A00.OK; + + -- Avoid optimization (dead variable removal of Ptr): + + if not Report.Equal (Ptr.C, Ptr.C) then -- Always false. + Report.Failed ("Unexpected error in Handle"); + end if; + exception + when Program_Error => R := F3A2A00.P_E; + when others => R := F3A2A00.O_E; + end Handle; + +end C3A2A01_1; + + + --==================================================================-- + + +with F3A2A00; +generic + type FD is new F3A2A00.Array_Type; + type FAF is access all FD; +procedure C3A2A01_2 (P: access FD; R: out F3A2A00.TC_Result_Kind); + + + --==================================================================-- + + +with Report; +procedure C3A2A01_2 (P: access FD; R: out F3A2A00.TC_Result_Kind) is + Ptr : FAF; + Index : Integer := F3A2A00.Array_Type'First; +begin + Ptr := P.all'Access; + R := F3A2A00.OK; + + -- Avoid optimization (dead variable removal of Ptr): + + if not Report.Equal (Ptr(Index).C, Ptr(Index).C) then -- Always false. + Report.Failed ("Unexpected error in C3A2A01_2 instance"); + end if; +exception + when Program_Error => R := F3A2A00.P_E; + when others => R := F3A2A00.O_E; +end C3A2A01_2; + + + --==================================================================-- + + +with F3A2A00; +with C3A2A01_0; +with C3A2A01_1; +with C3A2A01_2; + +with Report; +procedure C3A2A01 is +begin -- C3A2A01. -- [ Level = 1 ] + + Report.Test ("C3A2A01", "Run-time accessibility checks: instance " & + "bodies. Type of X'Access is passed as actual to instance"); + + + SUBTEST1: + declare -- [ Level = 2 ] + Result : F3A2A00.TC_Result_Kind; + begin -- SUBTEST1. + + declare -- [ Level = 3 ] + type AccArr_L3 is access all F3A2A00.Array_Type; + begin + declare -- [ Level = 4 ] + -- The accessibility level of Pack.X is that of the instantiation + -- (4). The accessibility level of the actual access type used to + -- instantiate Pack is 3. Therefore, the X'Access in Pack + -- propagates Program_Error when the instance body is elaborated: + + package Pack is new C3A2A01_0 (F3A2A00.Array_Type, AccArr_L3); + begin + Result := F3A2A00.OK; + end; + exception + when Program_Error => Result := F3A2A00.P_E; -- Expected result. + when others => Result := F3A2A00.O_E; + end; + + F3A2A00.TC_Display_Results (Result, F3A2A00.P_E, "SUBTEST #1"); + + end SUBTEST1; + + + + SUBTEST2: + declare -- [ Level = 2 ] + Result : F3A2A00.TC_Result_Kind; + begin -- SUBTEST2. + + declare -- [ Level = 3 ] + -- The instantiation of C3A2A01_1 should NOT result in any + -- exceptions. + + type AccTag_L3 is access all F3A2A00.Tagged_Type; + + package Pack_OK is new C3A2A01_1 (F3A2A00.Tagged_Type, + AccTag_L3, + F3A2A00.X_L0); + begin + -- The accessibility level of the actual object used to instantiate + -- Pack_OK is 0. The accessibility level of the actual access type + -- used to instantiate Pack_OK is 3. Therefore, the FObj'Access in + -- Pack_OK.Handle does not raise an exception when the subprogram is + -- called. If an exception is (incorrectly) raised, however, it is + -- handled within the subprogram: + + Pack_OK.Handle (Result); + end; + + F3A2A00.TC_Display_Results (Result, F3A2A00.OK, "SUBTEST #2"); + + exception + when Program_Error => + Report.Failed ("SUBTEST #2: Program_Error incorrectly raised " & + "during instantiation of generic"); + when others => + Report.Failed ("SUBTEST #2: Unexpected exception raised " & + "during instantiation of generic"); + end SUBTEST2; + + + + SUBTEST3: + declare -- [ Level = 2 ] + Result : F3A2A00.TC_Result_Kind; + begin -- SUBTEST3. + + declare -- [ Level = 3 ] + -- The instantiation of C3A2A01_1 should NOT result in any + -- exceptions. + + X_L3: F3A2A00.Tagged_Type; + + package Pack_PE is new C3A2A01_1 (F3A2A00.Tagged_Type, + F3A2A00.AccTag_L0, + X_L3); + begin + -- The accessibility level of the actual object used to instantiate + -- Pack_PE is 3. The accessibility level of the actual access type + -- used to instantiate Pack_PE is 0. Therefore, the FObj'Access in + -- Pack_OK.Handle raises Program_Error when the subprogram is + -- called. The exception is handled within the subprogram: + + Pack_PE.Handle (Result); + end; + + F3A2A00.TC_Display_Results (Result, F3A2A00.P_E, "SUBTEST #3"); + + exception + when Program_Error => + Report.Failed ("SUBTEST #3: Program_Error incorrectly raised " & + "during instantiation of generic"); + when others => + Report.Failed ("SUBTEST #3: Unexpected exception raised " & + "during instantiation of generic"); + end SUBTEST3; + + + + SUBTEST4: + declare -- [ Level = 2 ] + Result1 : F3A2A00.TC_Result_Kind; + Result2 : F3A2A00.TC_Result_Kind; + begin -- SUBTEST4. + + declare -- [ Level = 3 ] + -- The instantiation of C3A2A01_2 should NOT result in any + -- exceptions. + + X_L3: aliased F3A2A00.Array_Type; + type AccArr_L3 is access all F3A2A00.Array_Type; + + procedure Proc is new C3A2A01_2 (F3A2A00.Array_Type, AccArr_L3); + begin + -- The accessibility level of Proc.P.all is that of the corresponding + -- actual during the call (in this case 3). The accessibility level of + -- the access type used to instantiate Proc is also 3. Therefore, the + -- P.all'Access in Proc does not raise an exception when the + -- subprogram is called. If an exception is (incorrectly) raised, + -- however, it is handled within the subprogram: + + Proc (X_L3'Access, Result1); + + F3A2A00.TC_Display_Results (Result1, F3A2A00.OK, + "SUBTEST #4: same levels"); + + declare -- [ Level = 4 ] + X_L4: aliased F3A2A00.Array_Type; + begin + -- Within this block, the accessibility level of the actual + -- corresponding to Proc.P.all is 4. Therefore, the P.all'Access + -- in Proc raises Program_Error when the subprogram is called. The + -- exception is handled within the subprogram: + + Proc (X_L4'Access, Result2); + + F3A2A00.TC_Display_Results (Result2, F3A2A00.P_E, + "SUBTEST #4: object at deeper level"); + end; + + end; + + exception + when Program_Error => + Report.Failed ("SUBTEST #4: Program_Error incorrectly raised " & + "during instantiation of generic"); + when others => + Report.Failed ("SUBTEST #4: Unexpected exception raised " & + "during instantiation of generic"); + end SUBTEST4; + + + Report.Result; + +end C3A2A01; diff --git a/gcc-4.9/gcc/testsuite/ada/acats/tests/c3/c3a2a02.a b/gcc-4.9/gcc/testsuite/ada/acats/tests/c3/c3a2a02.a new file mode 100644 index 000000000..23b2c1c5d --- /dev/null +++ b/gcc-4.9/gcc/testsuite/ada/acats/tests/c3/c3a2a02.a @@ -0,0 +1,396 @@ +-- C3A2A02.A +-- +-- Grant of Unlimited Rights +-- +-- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687, +-- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained +-- unlimited rights in the software and documentation contained herein. +-- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making +-- this public release, the Government intends to confer upon all +-- recipients unlimited rights equal to those held by the Government. +-- These rights include rights to use, duplicate, release or disclose the +-- released technical data and computer software in whole or in part, in +-- any manner and for any purpose whatsoever, and to have or permit others +-- to do so. +-- +-- DISCLAIMER +-- +-- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR +-- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED +-- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE +-- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE +-- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A +-- PARTICULAR PURPOSE OF SAID MATERIAL. +--* +-- +-- OBJECTIVE: +-- Check that, for X'Access of a general access type A, Program_Error is +-- raised if the accessibility level of X is deeper than that of A. +-- Check for cases where X'Access occurs in an instance body, and A +-- is a type either declared inside the instance, or declared outside +-- the instance but not passed as an actual during instantiation. +-- +-- TEST DESCRIPTION: +-- In order to satisfy accessibility requirements, the designated +-- object X must be at the same or a less deep nesting level than the +-- general access type A -- X must "live" as long as A. Nesting +-- levels are the run-time nestings of masters: block statements; +-- subprogram, task, and entry bodies; and accept statements. Packages +-- are invisible to accessibility rules. +-- +-- This test declares three generic packages: +-- +-- (1) One in which X is of a formal tagged derived type and declared +-- in the body, A is a type declared outside the instance, and +-- X'Access occurs in the declarative part of a nested subprogram. +-- +-- (2) One in which X is a formal object of a tagged type, A is a +-- type declared outside the instance, and X'Access occurs in the +-- declarative part of the body. +-- +-- (3) One in which there are two X's and two A's. In the first pair, +-- X is a formal in object of a tagged type, A is declared in the +-- specification, and X'Access occurs in the declarative part of +-- the body. In the second pair, X is of a formal derived type, +-- X and A are declared in the specification, and X'Access occurs +-- in the sequence of statements of the body. +-- +-- The test verifies the following: +-- +-- For (1), Program_Error is raised when the nested subprogram is +-- called, if the generic package is instantiated at a deeper level +-- than that of A. The exception is propagated to the innermost +-- enclosing master. Also, check that Program_Error is not raised +-- if the instantiation is at the same level as that of A. +-- +-- For (2), Program_Error is raised upon instantiation if the object +-- passed as an actual during instantiation has an accessibility level +-- deeper than that of A. The exception is propagated to the innermost +-- enclosing master. Also, check that Program_Error is not raised if +-- the level of the actual object is not deeper than that of A. +-- +-- For (3), Program_Error is not raised, for actual objects at +-- various accessibility levels (since A will have at least the same +-- accessibility level as X in all cases, no exception should ever +-- be raised). +-- +-- TEST FILES: +-- The following files comprise this test: +-- +-- F3A2A00.A +-- -> C3A2A02.A +-- +-- +-- CHANGE HISTORY: +-- 12 May 95 SAIC Initial prerelease version. +-- 10 Jul 95 SAIC Modified code to avoid dead variable optimization. +-- 26 Jun 98 EDS Added pragma Elaborate (C3A2A02_0) to package +-- package C3A2A02_3, in order to avoid possible +-- instantiation error. +--! + +with F3A2A00; +generic + type FD is new F3A2A00.Tagged_Type with private; +package C3A2A02_0 is + procedure Proc; +end C3A2A02_0; + + + --==================================================================-- + + +with Report; +package body C3A2A02_0 is + X : aliased FD; + + procedure Proc is + Ptr : F3A2A00.AccTagClass_L0 := X'Access; + begin + -- Avoid optimization (dead variable removal of Ptr): + + if not Report.Equal (Ptr.C, Ptr.C) then -- Always false. + Report.Failed ("Unexpected error in Proc"); + end if; + end Proc; +end C3A2A02_0; + + + --==================================================================-- + + +with F3A2A00; +generic + FObj : in out F3A2A00.Tagged_Type; +package C3A2A02_1 is + procedure Dummy; -- Needed to allow package body. +end C3A2A02_1; + + + --==================================================================-- + + +with Report; +package body C3A2A02_1 is + Ptr : F3A2A00.AccTag_L0 := FObj'Access; + + procedure Dummy is + begin + null; + end Dummy; +begin + -- Avoid optimization (dead variable removal of Ptr): + + if not Report.Equal (Ptr.C, Ptr.C) then -- Always false. + Report.Failed ("Unexpected error in C3A2A02_1 instance"); + end if; +end C3A2A02_1; + + + --==================================================================-- + + +with F3A2A00; +generic + type FD is new F3A2A00.Array_Type; + FObj : in F3A2A00.Tagged_Type; +package C3A2A02_2 is + type GAF is access all FD; + type GAO is access constant F3A2A00.Tagged_Type; + XG : aliased FD; + PtrF : GAF; + Index : Integer := FD'First; + + procedure Dummy; -- Needed to allow package body. +end C3A2A02_2; + + + --==================================================================-- + + +with Report; +package body C3A2A02_2 is + PtrO : GAO := FObj'Access; + + procedure Dummy is + begin + null; + end Dummy; +begin + PtrF := XG'Access; + + -- Avoid optimization (dead variable removal of PtrO and/or PtrF): + + if not Report.Equal (PtrO.C, PtrO.C) then -- Always false. + Report.Failed ("Unexpected error in C3A2A02_2 instance: PtrO"); + end if; + + if not Report.Equal (PtrF(Index).C, PtrF(Index).C) then -- Always false. + Report.Failed ("Unexpected error in C3A2A02_2 instance: PtrF"); + end if; +end C3A2A02_2; + + + --==================================================================-- + + +-- The instantiation of C3A2A02_0 should NOT result in any exceptions. + +with F3A2A00; +with C3A2A02_0; +pragma Elaborate (C3A2A02_0); +package C3A2A02_3 is new C3A2A02_0 (F3A2A00.Tagged_Type); + + + --==================================================================-- + + +with F3A2A00; +with C3A2A02_0; +with C3A2A02_1; +with C3A2A02_2; +with C3A2A02_3; + +with Report; +procedure C3A2A02 is +begin -- C3A2A02. -- [ Level = 1 ] + + Report.Test ("C3A2A02", "Run-time accessibility checks: instance " & + "bodies. Type of X'Access is local or global to instance"); + + + SUBTEST1: + declare -- [ Level = 2 ] + Result1 : F3A2A00.TC_Result_Kind; + Result2 : F3A2A00.TC_Result_Kind; + begin -- SUBTEST1. + + declare -- [ Level = 3 ] + package Pack_Same_Level renames C3A2A02_3; + begin + -- The accessibility level of Pack_Same_Level.X is that of the + -- instance (0), not that of the renaming declaration. The level of + -- the type of Pack_Same_Level.X'Access (F3A2A00.AccTagClass_L0) is + -- 0. Therefore, the X'Access in Pack_Same_Level.Proc does not raise + -- an exception when the subprogram is called. The level of execution + -- of the subprogram is irrelevant: + + Pack_Same_Level.Proc; + Result1 := F3A2A00.OK; -- Expected result. + exception + when Program_Error => Result1 := F3A2A00.P_E; + when others => Result1 := F3A2A00.O_E; + end; + + F3A2A00.TC_Display_Results (Result1, F3A2A00.OK, + "SUBTEST #1 (same level)"); + + + declare -- [ Level = 3 ] + -- The instantiation of C3A2A02_0 should NOT result in any + -- exceptions. + + package Pack_Deeper_Level is new C3A2A02_0 (F3A2A00.Tagged_Type); + begin + -- The accessibility level of Pack_Deeper_Level.X is that of the + -- instance (3). The level of the type of Pack_Deeper_Level.X'Access + -- (F3A2A00.AccTagClass_L0) is 0. Therefore, the X'Access in + -- Pack_Deeper_Level.Proc propagates Program_Error when the + -- subprogram is called: + + Pack_Deeper_Level.Proc; + Result2 := F3A2A00.OK; + exception + when Program_Error => Result2 := F3A2A00.P_E; -- Expected result. + when others => Result2 := F3A2A00.O_E; + end; + + F3A2A00.TC_Display_Results (Result2, F3A2A00.P_E, + "SUBTEST #1: deeper level"); + + exception + when Program_Error => + Report.Failed ("SUBTEST #1: Program_Error incorrectly raised " & + "during instantiation of generic"); + when others => + Report.Failed ("SUBTEST #1: Unexpected exception raised " & + "during instantiation of generic"); + end SUBTEST1; + + + + SUBTEST2: + declare -- [ Level = 2 ] + Result1 : F3A2A00.TC_Result_Kind; + Result2 : F3A2A00.TC_Result_Kind; + begin -- SUBTEST2. + + declare -- [ Level = 3 ] + X_L3 : F3A2A00.Tagged_Type; + begin + declare -- [ Level = 4 ] + -- The accessibility level of the actual object corresponding to + -- FObj in Pack_PE is 3. The level of the type of FObj'Access + -- (F3A2A00.AccTag_L0) is 0. Therefore, the FObj'Access in Pack_PE + -- propagates Program_Error when the instance body is elaborated: + + package Pack_PE is new C3A2A02_1 (X_L3); + begin + Result1 := F3A2A00.OK; + end; + exception + when Program_Error => Result1 := F3A2A00.P_E; -- Expected result. + when others => Result1 := F3A2A00.O_E; + end; + + F3A2A00.TC_Display_Results (Result1, F3A2A00.P_E, + "SUBTEST #2: deeper level"); + + + begin -- [ Level = 3 ] + declare -- [ Level = 4 ] + -- The accessibility level of the actual object corresponding to + -- FObj in Pack_OK is 0. The level of the type of FObj'Access + -- (F3A2A00.AccTag_L0) is also 0. Therefore, the FObj'Access in + -- Pack_OK does not raise an exception when the instance body is + -- elaborated: + + package Pack_OK is new C3A2A02_1 (F3A2A00.X_L0); + begin + Result2 := F3A2A00.OK; -- Expected result. + end; + exception + when Program_Error => Result2 := F3A2A00.P_E; + when others => Result2 := F3A2A00.O_E; + end; + + F3A2A00.TC_Display_Results (Result2, F3A2A00.OK, + "SUBTEST #2: same level"); + + end SUBTEST2; + + + + SUBTEST3: + declare -- [ Level = 2 ] + Result1 : F3A2A00.TC_Result_Kind; + Result2 : F3A2A00.TC_Result_Kind; + begin -- SUBTEST3. + + declare -- [ Level = 3 ] + X_L3 : F3A2A00.Tagged_Type; + begin + declare -- [ Level = 4 ] + -- Since the accessibility level of the type of X'Access in + -- both cases within Pack_OK1 is that of the instance, and since + -- X is either passed as an actual (in which case its level will + -- not be deeper than that of the instance) or is declared within + -- the instance (in which case its level is the same as that of + -- the instance), no exception should be raised when the instance + -- body is elaborated: + + package Pack_OK1 is new C3A2A02_2 (F3A2A00.Array_Type, X_L3); + begin + Result1 := F3A2A00.OK; -- Expected result. + end; + exception + when Program_Error => Result1 := F3A2A00.P_E; + when others => Result1 := F3A2A00.O_E; + end; + + F3A2A00.TC_Display_Results (Result1, F3A2A00.OK, + "SUBTEST #3: 1st okay case"); + + + declare -- [ Level = 3 ] + type My_Array is new F3A2A00.Array_Type; + begin + declare -- [ Level = 4 ] + -- Since the accessibility level of the type of X'Access in + -- both cases within Pack_OK2 is that of the instance, and since + -- X is either passed as an actual (in which case its level will + -- not be deeper than that of the instance) or is declared within + -- the instance (in which case its level is the same as that of + -- the instance), no exception should be raised when the instance + -- body is elaborated: + + package Pack_OK2 is new C3A2A02_2 (My_Array, F3A2A00.X_L0); + begin + Result2 := F3A2A00.OK; -- Expected result. + end; + exception + when Program_Error => Result2 := F3A2A00.P_E; + when others => Result2 := F3A2A00.O_E; + end; + + F3A2A00.TC_Display_Results (Result2, F3A2A00.OK, + "SUBTEST #3: 2nd okay case"); + + + end SUBTEST3; + + + + Report.Result; + +end C3A2A02; |