cc1111a.ada

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

-- CC1111A.ADA

--                             Grant of Unlimited Rights
--
--     Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687,
--     F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained 
--     unlimited rights in the software and documentation contained herein.
--     Unlimited rights are defined in DFAR 252.227-7013(a)(19).  By making 
--     this public release, the Government intends to confer upon all 
--     recipients unlimited rights  equal to those held by the Government.  
--     These rights include rights to use, duplicate, release or disclose the 
--     released technical data and computer software in whole or in part, in 
--     any manner and for any purpose whatsoever, and to have or permit others 
--     to do so.
--
--                                    DISCLAIMER
--
--     ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR
--     DISCLOSED ARE AS IS.  THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED 
--     WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF 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 AFTER A GENERIC UNIT IS INSTANTIATED, THE SUBTYPE OF
--     AN IN OUT OBJECT PARAMETER IS DETERMINED BY THE ACTUAL PARAMETER
--     (TESTS INTEGER, ENUMERATION, FLOATING POINT, FIXED POINT, ARRAY,
--     ACCESS, AND DISCRIMINATED TYPES).

-- HISTORY:
--     BCB 03/28/88  CREATED ORIGINAL TEST.
--     PWN 01/31/95  REMOVED INCONSISTENCIES WITH ADA 9X.

WITH REPORT; USE REPORT;

PROCEDURE CC1111A IS

     SUBTYPE INT IS INTEGER RANGE 0..5;
     INTVAR : INTEGER RANGE 1..3;

     TYPE ENUM IS (ONE, TWO, THREE, FOUR, FIVE, SIX, SEVEN, EIGHT);
     SUBTYPE SUBENUM IS ENUM RANGE ONE .. FIVE;
     ENUMVAR : ENUM RANGE TWO .. THREE;

     TYPE FLT IS DIGITS 5 RANGE -5.0 .. 5.0;
     SUBTYPE SUBFLT IS FLT RANGE -1.0 .. 1.0;
     FLTVAR : FLT RANGE 0.0 .. 1.0;

     TYPE FIX IS DELTA 0.5 RANGE -5.0 .. 5.0;
     SUBTYPE SUBFIX IS FIX RANGE -1.0 .. 1.0;
     FIXVAR : FIX RANGE 0.0 .. 1.0;

     SUBTYPE STR IS STRING (1..10);
     STRVAR : STRING (1..5);

     TYPE REC (DISC : INTEGER := 5) IS RECORD
          NULL;
     END RECORD;
     SUBTYPE SUBREC IS REC (6);
     RECVAR : REC(5);
     SUBRECVAR : SUBREC;

     TYPE ACCREC IS ACCESS REC;
     SUBTYPE A1 IS ACCREC(1);
     SUBTYPE A2 IS ACCREC(2);
     A1VAR : A1 := NEW REC(1);
     A2VAR : A2 := NEW REC(2);

     PACKAGE P IS
          TYPE PRIV IS PRIVATE;
     PRIVATE
          TYPE PRIV IS RANGE 1 .. 100;
          SUBTYPE SUBPRIV IS PRIV RANGE 5 .. 10;
          PRIVVAR : PRIV RANGE 8 .. 10;
     END P;

     PACKAGE BODY P IS
          FUNCTION PRIVEQUAL (ONE, TWO : SUBPRIV) RETURN BOOLEAN;

          FUNCTION PRIVEQUAL (ONE, TWO : SUBPRIV) RETURN BOOLEAN IS
          BEGIN
               RETURN ONE = TWO;
          END PRIVEQUAL;

          GENERIC
               INPUT : SUBPRIV;
               OUTPUT : IN OUT SUBPRIV;
          PROCEDURE I;

          PROCEDURE I IS
          BEGIN
               OUTPUT := INPUT;
               FAILED ("SUBTYPE NOT DETERMINED BY ACTUAL PARAMETER - " &
                       "PRIVATE TYPE");
               IF PRIVEQUAL (OUTPUT, OUTPUT) THEN
                    COMMENT ("DON'T OPTIMIZE OUTPUT");
               END IF;
          EXCEPTION
               WHEN CONSTRAINT_ERROR =>
                    NULL;
               WHEN OTHERS =>
                    FAILED ("WRONG EXCEPTION RAISED");
          END I;

          PROCEDURE I1 IS NEW I (5, PRIVVAR);
          PROCEDURE I2 IS NEW I (SUBPRIV'FIRST, PRIVVAR);

     BEGIN
          TEST ("CC1111A", "CHECK THAT AFTER A GENERIC UNIT IS " &
                           "INSTANTIATED, THE SUBTYPE OF AN IN OUT " &
                           "OBJECT PARAMETER IS DETERMINED BY THE " &
                           "ACTUAL PARAMETER (TESTS INTEGER, " &
                           "ENUMERATION, FLOATING POINT, FIXED POINT " &
                           ", ARRAY, ACCESS, AND DISCRIMINATED TYPES)");

          I1;
          I2;
     END P;

     USE P;

     GENERIC
          TYPE GP IS PRIVATE;
     FUNCTION GEN_IDENT (X : GP) RETURN GP;

     GENERIC
          INPUT : INT;
          OUTPUT : IN OUT INT;
     PROCEDURE B;

     GENERIC
          INPUT : SUBENUM;
          OUTPUT : IN OUT SUBENUM;
     PROCEDURE C;

     GENERIC
          INPUT : SUBFLT;
          OUTPUT : IN OUT SUBFLT;
     PROCEDURE D;

     GENERIC
          INPUT : SUBFIX;
          OUTPUT : IN OUT SUBFIX;
     PROCEDURE E;

     GENERIC
          INPUT : STR;
          OUTPUT : IN OUT STR;
     PROCEDURE F;

     GENERIC
          INPUT : A1;
          OUTPUT : IN OUT A1;
     PROCEDURE G;

     GENERIC
          INPUT : SUBREC;
          OUTPUT : IN OUT SUBREC;
     PROCEDURE H;

     GENERIC
          TYPE GP IS PRIVATE;
     FUNCTION GENEQUAL (ONE, TWO : GP) RETURN BOOLEAN;

     FUNCTION GENEQUAL (ONE, TWO : GP) RETURN BOOLEAN IS
     BEGIN
          RETURN ONE = TWO;
     END GENEQUAL;

     FUNCTION GEN_IDENT (X : GP) RETURN GP IS
     BEGIN
               RETURN X;
     END GEN_IDENT;

     FUNCTION INT_IDENT IS NEW GEN_IDENT (INT);
     FUNCTION SUBENUM_IDENT IS NEW GEN_IDENT (SUBENUM);
     FUNCTION SUBFLT_IDENT IS NEW GEN_IDENT (SUBFLT);
     FUNCTION SUBFIX_IDENT IS NEW GEN_IDENT (SUBFIX);

     FUNCTION ENUMEQUAL IS NEW GENEQUAL (SUBENUM);
     FUNCTION FLTEQUAL IS NEW GENEQUAL (SUBFLT);
     FUNCTION FIXEQUAL IS NEW GENEQUAL (SUBFIX);
     FUNCTION STREQUAL IS NEW GENEQUAL (STR);
     FUNCTION ACCEQUAL IS NEW GENEQUAL (A2);
     FUNCTION RECEQUAL IS NEW GENEQUAL (REC);

     PROCEDURE B IS
     BEGIN
          OUTPUT := INPUT;
          FAILED ("SUBTYPE NOT DETERMINED BY ACTUAL PARAMETER - " &
                  "INTEGER TYPE");
          IF EQUAL (OUTPUT, OUTPUT) THEN
               COMMENT ("DON'T OPTIMIZE OUTPUT");
          END IF;
     EXCEPTION
          WHEN CONSTRAINT_ERROR =>
               NULL;
          WHEN OTHERS =>
               FAILED ("WRONG EXCEPTION RAISED");
     END B;

     PROCEDURE C IS
     BEGIN
          OUTPUT := INPUT;
          FAILED ("SUBTYPE NOT DETERMINED BY ACTUAL PARAMETER - " &
                  "ENUMERATION TYPE");
          IF ENUMEQUAL (OUTPUT, OUTPUT) THEN
               COMMENT ("DON'T OPTIMIZE OUTPUT");
          END IF;
     EXCEPTION
          WHEN CONSTRAINT_ERROR =>
               NULL;
          WHEN OTHERS =>
               FAILED ("WRONG EXCEPTION RAISED");
     END C;

     PROCEDURE D IS
     BEGIN
          OUTPUT := INPUT;
          FAILED ("SUBTYPE NOT DETERMINED BY ACTUAL PARAMETER - " &
                  "FLOATING POINT TYPE");
          IF FLTEQUAL (OUTPUT, OUTPUT) THEN
               COMMENT ("DON'T OPTIMIZE OUTPUT");
          END IF;
     EXCEPTION
          WHEN CONSTRAINT_ERROR =>
               NULL;
          WHEN OTHERS =>
               FAILED ("WRONG EXCEPTION RAISED");
     END D;

     PROCEDURE E IS
     BEGIN
          OUTPUT := INPUT;
          FAILED ("SUBTYPE NOT DETERMINED BY ACTUAL PARAMETER - " &
                  "FIXED POINT TYPE");
          IF FIXEQUAL (OUTPUT, OUTPUT) THEN
               COMMENT ("DON'T OPTIMIZE OUTPUT");
          END IF;
     EXCEPTION
          WHEN CONSTRAINT_ERROR =>
               NULL;
          WHEN OTHERS =>
               FAILED ("WRONG EXCEPTION RAISED");
     END E;

     PROCEDURE F IS
     BEGIN
          OUTPUT := INPUT;
          FAILED ("SUBTYPE NOT DETERMINED BY ACTUAL PARAMETER - " &
                  "ARRAY TYPE");
          IF STREQUAL (OUTPUT, OUTPUT) THEN
               COMMENT ("DON'T OPTIMIZE OUTPUT");
          END IF;
     EXCEPTION
          WHEN CONSTRAINT_ERROR =>
               NULL;
          WHEN OTHERS =>
               FAILED ("WRONG EXCEPTION RAISED");
     END F;

     PROCEDURE G IS
     BEGIN
          OUTPUT := INPUT;
          FAILED ("SUBTYPE NOT DETERMINED BY ACTUAL PARAMETER - " &
                  "ACCESS TYPE");
          IF ACCEQUAL (OUTPUT, OUTPUT) THEN
               COMMENT ("DON'T OPTIMIZE OUTPUT");
          END IF;
     EXCEPTION
          WHEN CONSTRAINT_ERROR =>
               NULL;
          WHEN OTHERS =>
               FAILED ("WRONG EXCEPTION RAISED");
     END G;

     PROCEDURE H IS
     BEGIN
          OUTPUT := INPUT;
          FAILED ("SUBTYPE NOT DETERMINED BY ACTUAL PARAMETER - " &
                  "DISCRIMINATED RECORD TYPE");
          IF RECEQUAL (OUTPUT, OUTPUT) THEN
               COMMENT ("DON'T OPTIMIZE OUTPUT");
          END IF;
     EXCEPTION
          WHEN CONSTRAINT_ERROR =>
               NULL;
          WHEN OTHERS =>
               FAILED ("WRONG EXCEPTION RAISED");
     END H;

     PROCEDURE B1 IS NEW B (4, INTVAR);
     PROCEDURE C1 IS NEW C (FOUR, ENUMVAR);
     PROCEDURE D1 IS NEW D (-1.0, FLTVAR);
     PROCEDURE E1 IS NEW E (-1.0, FIXVAR);
     PROCEDURE F1 IS NEW F ("9876543210", STRVAR);
     PROCEDURE G1 IS NEW G (A1VAR, A2VAR);
     PROCEDURE H1 IS NEW H (SUBRECVAR, RECVAR);

     PROCEDURE B2 IS NEW B (INT_IDENT(INT'FIRST), INTVAR);
     PROCEDURE C2 IS NEW C (SUBENUM_IDENT(SUBENUM'FIRST), ENUMVAR);
     PROCEDURE D2 IS NEW D (SUBFLT_IDENT(SUBFLT'FIRST), FLTVAR);
     PROCEDURE E2 IS NEW E (SUBFIX_IDENT(SUBFIX'FIRST), FIXVAR);

BEGIN

     B1;
     C1;
     D1;
     E1;
     F1;
     G1;
     H1;

     B2;
     C2;
     D2;
     E2;

     RESULT;
END CC1111A;