c46051a.ada

来自「用于进行gcc测试」· ADA 代码 · 共 415 行

-- 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;