diff options
Diffstat (limited to 'gcc/testsuite/ada/acats/tests/c4/c46051a.ada')
| -rw-r--r-- | gcc/testsuite/ada/acats/tests/c4/c46051a.ada | 414 |
1 files changed, 414 insertions, 0 deletions
diff --git a/gcc/testsuite/ada/acats/tests/c4/c46051a.ada b/gcc/testsuite/ada/acats/tests/c4/c46051a.ada new file mode 100644 index 000000000..9468e8f76 --- /dev/null +++ b/gcc/testsuite/ada/acats/tests/c4/c46051a.ada @@ -0,0 +1,414 @@ +-- C46051A.ADA + +-- Grant of Unlimited Rights +-- +-- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687, +-- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained +-- unlimited rights in the software and documentation contained herein. +-- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making +-- this public release, the Government intends to confer upon all +-- recipients unlimited rights equal to those held by the Government. +-- These rights include rights to use, duplicate, release or disclose the +-- released technical data and computer software in whole or in part, in +-- any manner and for any purpose whatsoever, and to have or permit others +-- to do so. +-- +-- DISCLAIMER +-- +-- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR +-- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED +-- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE +-- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE +-- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A +-- PARTICULAR PURPOSE OF SAID MATERIAL. +--* +-- CHECK THAT ENUMERATION, RECORD, ACCESS, PRIVATE, AND TASK VALUES CAN +-- BE CONVERTED IF THE OPERAND AND TARGET TYPES ARE RELATED BY +-- DERIVATION. + +-- R.WILLIAMS 9/8/86 + +WITH REPORT; USE REPORT; +PROCEDURE C46051A IS + +BEGIN + TEST ( "C46051A", "CHECK THAT ENUMERATION, RECORD, ACCESS, " & + "PRIVATE, AND TASK VALUES CAN BE CONVERTED " & + "IF THE OPERAND AND TARGET TYPES ARE " & + "RELATED BY DERIVATION" ); + + DECLARE + TYPE ENUM IS (A, AB, ABC, ABCD); + E : ENUM := ABC; + + TYPE ENUM1 IS NEW ENUM; + E1 : ENUM1 := ENUM1'VAL (IDENT_INT (2)); + + TYPE ENUM2 IS NEW ENUM; + E2 : ENUM2 := ABC; + + TYPE NENUM1 IS NEW ENUM1; + NE : NENUM1 := NENUM1'VAL (IDENT_INT (2)); + BEGIN + IF ENUM (E) /= E THEN + FAILED ( "INCORRECT CONVERSION OF 'ENUM (E)'" ); + END IF; + + IF ENUM (E1) /= E THEN + FAILED ( "INCORRECT CONVERSION OF 'ENUM (E1)'" ); + END IF; + + IF ENUM1 (E2) /= E1 THEN + FAILED ( "INCORRECT CONVERSION OF 'ENUM1 (E2)'" ); + END IF; + + IF ENUM2 (NE) /= E2 THEN + FAILED ( "INCORRECT CONVERSION OF 'ENUM2 (NE)'" ); + END IF; + + IF NENUM1 (E) /= NE THEN + FAILED ( "INCORRECT CONVERSION OF 'NENUM (E)'" ); + END IF; + EXCEPTION + WHEN OTHERS => + FAILED ( "EXCEPTION RAISED DURING CONVERSION OF " & + "ENUMERATION TYPES" ); + END; + + DECLARE + TYPE REC IS + RECORD + NULL; + END RECORD; + + R : REC; + + TYPE REC1 IS NEW REC; + R1 : REC1; + + TYPE REC2 IS NEW REC; + R2 : REC2; + + TYPE NREC1 IS NEW REC1; + NR : NREC1; + BEGIN + IF REC (R) /= R THEN + FAILED ( "INCORRECT CONVERSION OF 'REC (R)'" ); + END IF; + + IF REC (R1) /= R THEN + FAILED ( "INCORRECT CONVERSION OF 'REC (R1)'" ); + END IF; + + IF REC1 (R2) /= R1 THEN + FAILED ( "INCORRECT CONVERSION OF 'REC1 (R2)'" ); + END IF; + + IF REC2 (NR) /= R2 THEN + FAILED ( "INCORRECT CONVERSION OF 'REC2 (NR)'" ); + END IF; + + IF NREC1 (R) /= NR THEN + FAILED ( "INCORRECT CONVERSION OF 'NREC (R)'" ); + END IF; + EXCEPTION + WHEN OTHERS => + FAILED ( "EXCEPTION RAISED DURING CONVERSION OF " & + "RECORD TYPES" ); + END; + + DECLARE + TYPE REC (D : INTEGER) IS + RECORD + NULL; + END RECORD; + + SUBTYPE CREC IS REC (3); + R : CREC; + + TYPE CREC1 IS NEW REC (3); + R1 : CREC1; + + TYPE CREC2 IS NEW REC (3); + R2 : CREC2; + + TYPE NCREC1 IS NEW CREC1; + NR : NCREC1; + BEGIN + IF CREC (R) /= R THEN + FAILED ( "INCORRECT CONVERSION OF 'CREC (R)'" ); + END IF; + + IF CREC (R1) /= R THEN + FAILED ( "INCORRECT CONVERSION OF 'CREC (R1)'" ); + END IF; + + IF CREC1 (R2) /= R1 THEN + FAILED ( "INCORRECT CONVERSION OF 'CREC1 (R2)'" ); + END IF; + + IF CREC2 (NR) /= R2 THEN + FAILED ( "INCORRECT CONVERSION OF 'CREC2 (NR)'" ); + END IF; + + IF NCREC1 (R) /= NR THEN + FAILED ( "INCORRECT CONVERSION OF 'NCREC (R)'" ); + END IF; + EXCEPTION + WHEN OTHERS => + FAILED ( "EXCEPTION RAISED DURING CONVERSION OF " & + "RECORD TYPES WITH DISCRIMINANTS" ); + END; + + DECLARE + TYPE REC IS + RECORD + NULL; + END RECORD; + + TYPE ACCREC IS ACCESS REC; + AR : ACCREC; + + TYPE ACCREC1 IS NEW ACCREC; + AR1 : ACCREC1; + + TYPE ACCREC2 IS NEW ACCREC; + AR2 : ACCREC2; + + TYPE NACCREC1 IS NEW ACCREC1; + NAR : NACCREC1; + + FUNCTION F (A : ACCREC) RETURN INTEGER IS + BEGIN + RETURN IDENT_INT (0); + END F; + + FUNCTION F (A : ACCREC1) RETURN INTEGER IS + BEGIN + RETURN IDENT_INT (1); + END F; + + FUNCTION F (A : ACCREC2) RETURN INTEGER IS + BEGIN + RETURN IDENT_INT (2); + END F; + + FUNCTION F (A : NACCREC1) RETURN INTEGER IS + BEGIN + RETURN IDENT_INT (3); + END F; + + BEGIN + IF F (ACCREC (AR)) /= 0 THEN + FAILED ( "INCORRECT CONVERSION OF 'ACCREC (AR)'" ); + END IF; + + IF F (ACCREC (AR1)) /= 0 THEN + FAILED ( "INCORRECT CONVERSION OF 'ACCREC (AR1)'" ); + END IF; + + IF F (ACCREC1 (AR2)) /= 1 THEN + FAILED ( "INCORRECT CONVERSION OF 'ACCREC1 (AR2)'" ); + END IF; + + IF F (ACCREC2 (NAR)) /= 2 THEN + FAILED ( "INCORRECT CONVERSION OF 'ACCREC2 (NAR)'" ); + END IF; + + IF F (NACCREC1 (AR)) /= 3 THEN + FAILED ( "INCORRECT CONVERSION OF 'NACCREC (AR)'" ); + END IF; + EXCEPTION + WHEN OTHERS => + FAILED ( "EXCEPTION RAISED DURING CONVERSION OF " & + "ACCESS TYPES" ); + END; + + DECLARE + TYPE REC (D : INTEGER) IS + RECORD + NULL; + END RECORD; + + TYPE ACCR IS ACCESS REC; + + SUBTYPE CACCR IS ACCR (3); + AR : CACCR; + + TYPE CACCR1 IS NEW ACCR (3); + AR1 : CACCR1; + + TYPE CACCR2 IS NEW ACCR (3); + AR2 : CACCR2; + + TYPE NCACCR1 IS NEW CACCR1; + NAR : NCACCR1; + + FUNCTION F (A : CACCR) RETURN INTEGER IS + BEGIN + RETURN IDENT_INT (0); + END F; + + FUNCTION F (A : CACCR1) RETURN INTEGER IS + BEGIN + RETURN IDENT_INT (1); + END F; + + FUNCTION F (A : CACCR2) RETURN INTEGER IS + BEGIN + RETURN IDENT_INT (2); + END F; + + FUNCTION F (A : NCACCR1) RETURN INTEGER IS + BEGIN + RETURN IDENT_INT (3); + END F; + + BEGIN + IF F (CACCR (AR)) /= 0 THEN + FAILED ( "INCORRECT CONVERSION OF 'CACCR (AR)'" ); + END IF; + + IF F (CACCR (AR1)) /= 0 THEN + FAILED ( "INCORRECT CONVERSION OF 'CACCR (AR1)'" ); + END IF; + + IF F (CACCR1 (AR2)) /= 1 THEN + FAILED ( "INCORRECT CONVERSION OF 'CACCR1 (AR2)'" ); + END IF; + + IF F (CACCR2 (NAR)) /= 2 THEN + FAILED ( "INCORRECT CONVERSION OF 'CACCR2 (NAR)'" ); + END IF; + + IF F (NCACCR1 (AR)) /= 3 THEN + FAILED ( "INCORRECT CONVERSION OF 'NCACCR (AR)'" ); + END IF; + EXCEPTION + WHEN OTHERS => + FAILED ( "EXCEPTION RAISED DURING CONVERSION OF " & + "CONSTRAINED ACCESS TYPES" ); + END; + + DECLARE + PACKAGE PKG1 IS + TYPE PRIV IS PRIVATE; + PRIVATE + TYPE PRIV IS + RECORD + NULL; + END RECORD; + END PKG1; + + USE PKG1; + + PACKAGE PKG2 IS + R : PRIV; + + TYPE PRIV1 IS NEW PRIV; + R1 : PRIV1; + + TYPE PRIV2 IS NEW PRIV; + R2 : PRIV2; + END PKG2; + + USE PKG2; + + PACKAGE PKG3 IS + TYPE NPRIV1 IS NEW PRIV1; + NR : NPRIV1; + END PKG3; + + USE PKG3; + BEGIN + IF PRIV (R) /= R THEN + FAILED ( "INCORRECT CONVERSION OF 'PRIV (R)'" ); + END IF; + + IF PRIV (R1) /= R THEN + FAILED ( "INCORRECT CONVERSION OF 'PRIV (R1)'" ); + END IF; + + IF PRIV1 (R2) /= R1 THEN + FAILED ( "INCORRECT CONVERSION OF 'PRIV1 (R2)'" ); + END IF; + + IF PRIV2 (NR) /= R2 THEN + FAILED ( "INCORRECT CONVERSION OF 'PRIV2 (NR)'" ); + END IF; + + IF NPRIV1 (R) /= NR THEN + FAILED ( "INCORRECT CONVERSION OF 'NPRIV (R)'" ); + END IF; + EXCEPTION + WHEN OTHERS => + FAILED ( "EXCEPTION RAISED DURING CONVERSION OF " & + "PRIVATE TYPES" ); + END; + + DECLARE + TASK TYPE TK; + T : TK; + + TYPE TK1 IS NEW TK; + T1 : TK1; + + TYPE TK2 IS NEW TK; + T2 : TK2; + + TYPE NTK1 IS NEW TK1; + NT : NTK1; + + TASK BODY TK IS + BEGIN + NULL; + END; + + FUNCTION F (T : TK) RETURN INTEGER IS + BEGIN + RETURN IDENT_INT (0); + END F; + + FUNCTION F (T : TK1) RETURN INTEGER IS + BEGIN + RETURN IDENT_INT (1); + END F; + + FUNCTION F (T : TK2) RETURN INTEGER IS + BEGIN + RETURN IDENT_INT (2); + END F; + + FUNCTION F (T : NTK1) RETURN INTEGER IS + BEGIN + RETURN IDENT_INT (3); + END F; + + BEGIN + IF F (TK (T)) /= 0 THEN + FAILED ( "INCORRECT CONVERSION OF 'TK (T))'" ); + END IF; + + IF F (TK (T1)) /= 0 THEN + FAILED ( "INCORRECT CONVERSION OF 'TK (T1))'" ); + END IF; + + IF F (TK1 (T2)) /= 1 THEN + FAILED ( "INCORRECT CONVERSION OF 'TK1 (T2))'" ); + END IF; + + IF F (TK2 (NT)) /= 2 THEN + FAILED ( "INCORRECT CONVERSION OF 'TK2 (NT))'" ); + END IF; + + IF F (NTK1 (T)) /= 3 THEN + FAILED ( "INCORRECT CONVERSION OF 'NTK (T))'" ); + END IF; + EXCEPTION + WHEN OTHERS => + FAILED ( "EXCEPTION RAISED DURING CONVERSION OF " & + "TASK TYPES" ); + END; + + RESULT; +END C46051A; |