c74306a.ada

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

-- C74306A.ADA

--                             Grant of Unlimited Rights
--
--     Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687,
--     F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained 
--     unlimited rights in the software and documentation contained herein.
--     Unlimited rights are defined in DFAR 252.227-7013(a)(19).  By making 
--     this public release, the Government intends to confer upon all 
--     recipients unlimited rights  equal to those held by the Government.  
--     These rights include rights to use, duplicate, release or disclose the 
--     released technical data and computer software in whole or in part, in 
--     any manner and for any purpose whatsoever, and to have or permit others 
--     to do so.
--
--                                    DISCLAIMER
--
--     ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR
--     DISCLOSED ARE AS IS.  THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED 
--     WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF 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:
--     AFTER THE FULL DECLARATION OF A DEFERRED CONSTANT, THE VALUE OF
--     THE CONSTANT MAY BE USED IN ANY EXPRESSION, PARTICULARLY
--     EXPRESSIONS IN WHICH THE USE WOULD BE ILLEGAL BEFORE THE FULL
--     DECLARATION.

-- HISTORY:
--     BCB 03/14/88  CREATED ORIGINAL TEST.

WITH REPORT; USE REPORT;

PROCEDURE C74306A IS

     GENERIC
          TYPE GENERAL_PURPOSE IS LIMITED PRIVATE;
          Y : IN OUT GENERAL_PURPOSE;
     FUNCTION IDENT (X : GENERAL_PURPOSE) RETURN GENERAL_PURPOSE;

     FUNCTION IDENT (X : GENERAL_PURPOSE) RETURN GENERAL_PURPOSE IS
     BEGIN
          IF EQUAL(3,3) THEN
               RETURN X;
          END IF;
          RETURN Y;
     END IDENT;

     PACKAGE P IS
          TYPE T IS PRIVATE;
          C : CONSTANT T;
     PRIVATE
          TYPE T IS RANGE 1 .. 100;

          TYPE A IS ARRAY(1..2) OF T;

          TYPE B IS ARRAY(INTEGER RANGE <>) OF T;

          TYPE D (DISC : T) IS RECORD
               NULL;
          END RECORD;

          C : CONSTANT T := 50;

          PARAM : T := 99;

          FUNCTION IDENT_T IS NEW IDENT (T, PARAM);

          FUNCTION F (X : T := C) RETURN T;

          SUBTYPE RAN IS T RANGE 1 .. C;

          SUBTYPE IND IS B(1..INTEGER(C));

          SUBTYPE DIS IS D (DISC => C);

          OBJ : T := C;

          CON : CONSTANT T := C;

          ARR : A := (5, C);

          PAR : T := IDENT_T (C);

          RANOBJ : T RANGE 1 .. C := C;

          INDOBJ : B(1..INTEGER(C));

          DIS_VAL : DIS;

          REN : T RENAMES C;

          GENERIC
               FOR_PAR : T := C;
          PACKAGE GENPACK IS
               VAL : T;
          END GENPACK;

          GENERIC
               IN_PAR : IN T;
          PACKAGE NEWPACK IS
               IN_VAL : T;
          END NEWPACK;
     END P;

     USE P;

     PACKAGE BODY P IS
          TYPE A1 IS ARRAY(1..2) OF T;

          TYPE B1 IS ARRAY(INTEGER RANGE <>) OF T;

          TYPE D1 (DISC1 : T) IS RECORD
               NULL;
          END RECORD;

          SUBTYPE RAN1 IS T RANGE 1 .. C;

          SUBTYPE IND1 IS B1(1..INTEGER(C));

          SUBTYPE DIS1 IS D1 (DISC1 => C);

          OBJ1 : T := C;

          FUNCVAR : T;

          CON1 : CONSTANT T := C;

          ARR1 : A1 := (5, C);

          PAR1 : T := IDENT_T (C);

          RANOBJ1 : T RANGE 1 .. C := C;

          INDOBJ1 : B1(1..INTEGER(C));

          DIS_VAL1 : DIS1;

          REN1 : T RENAMES C;

          FUNCTION F (X : T := C) RETURN T IS
          BEGIN
               RETURN C;
          END F;

          PACKAGE BODY GENPACK IS
          BEGIN
               VAL := FOR_PAR;
          END GENPACK;

          PACKAGE BODY NEWPACK IS
          BEGIN
               IN_VAL := IN_PAR;
          END NEWPACK;

          PACKAGE PACK IS NEW GENPACK (FOR_PAR => C);

          PACKAGE NPACK IS NEW NEWPACK (IN_PAR => C);
     BEGIN
          TEST ("C74306A", "AFTER THE FULL DECLARATION OF A DEFERRED " &
                           "CONSTANT, THE VALUE OF THE CONSTANT MAY " &
                           "BE USED IN ANY EXPRESSION, PARTICULARLY " &
                           "EXPRESSIONS IN WHICH THE USE WOULD BE " &
                           "ILLEGAL BEFORE THE FULL DECLARATION");

          IF OBJ /= IDENT_T(50) THEN
               FAILED ("IMPROPER VALUE FOR OBJ");
          END IF;

          IF CON /= IDENT_T(50) THEN
               FAILED ("IMPROPER VALUE FOR CON");
          END IF;

          IF ARR /= (IDENT_T(5), IDENT_T(50)) THEN
               FAILED ("IMPROPER VALUES FOR ARR");
          END IF;

          IF PAR /= IDENT_T(50) THEN
               FAILED ("IMPROPER VALUE FOR PAR");
          END IF;

          IF OBJ1 /= IDENT_T(50) THEN
               FAILED ("IMPROPER VALUE FOR OBJ1");
          END IF;

          IF CON1 /= IDENT_T(50) THEN
               FAILED ("IMPROPER VALUE FOR CON1");
          END IF;

          IF ARR1 /= (IDENT_T(5), IDENT_T(50)) THEN
               FAILED ("IMPROPER VALUES FOR ARR1");
          END IF;

          IF PAR1 /= IDENT_T(50) THEN
               FAILED ("IMPROPER VALUE FOR PAR1");
          END IF;

          IF PACK.VAL /= IDENT_T(50) THEN
               FAILED ("IMPROPER VALUE FOR PACK.VAL");
          END IF;

          IF NPACK.IN_VAL /= IDENT_T(50) THEN
               FAILED ("IMPROPER VALUE FOR NPACK.IN_VAL");
          END IF;

          IF RAN'LAST /= IDENT_T(50) THEN
               FAILED ("IMPROPER VALUE FOR RAN'LAST");
          END IF;

          IF RANOBJ /= IDENT_T(50) THEN
               FAILED ("IMPROPER VALUE FOR RANOBJ");
          END IF;

          IF IND'LAST /= IDENT_INT(50) THEN
               FAILED ("IMPROPER VALUE FOR IND'LAST");
          END IF;

          IF INDOBJ'LAST /= IDENT_INT(50) THEN
               FAILED ("IMPROPER VALUE FOR INDOBJ'LAST");
          END IF;

          IF DIS_VAL.DISC /= IDENT_T(50) THEN
               FAILED ("IMPROPER VALUE FOR DIS_VAL.DISC");
          END IF;

          IF REN /= IDENT_T(50) THEN
               FAILED ("IMPROPER VALUE FOR REN");
          END IF;

          IF RAN1'LAST /= IDENT_T(50) THEN
               FAILED ("IMPROPER VALUE FOR RAN1'LAST");
          END IF;

          IF RANOBJ1 /= IDENT_T(50) THEN
               FAILED ("IMPROPER VALUE FOR RANOBJ1");
          END IF;

          IF IND1'LAST /= IDENT_INT(50) THEN
               FAILED ("IMPROPER VALUE FOR IND1'LAST");
          END IF;

          IF INDOBJ1'LAST /= IDENT_INT(50) THEN
               FAILED ("IMPROPER VALUE FOR INDOBJ1'LAST");
          END IF;

          IF DIS_VAL1.DISC1 /= IDENT_T(50) THEN
               FAILED ("IMPROPER VALUE FOR DIS_VAL1.DISC1");
          END IF;

          IF REN1 /= IDENT_T(50) THEN
               FAILED ("IMPROPER VALUE FOR REN1");
          END IF;

          FUNCVAR := F(C);

          IF FUNCVAR /= IDENT_T(50) THEN
               FAILED ("IMPROPER VALUE FOR FUNCVAR");
          END IF;

          RESULT;
     END P;

BEGIN
     DECLARE
          TYPE ARR IS ARRAY(1..2) OF T;

          VAL1 : T := C;

          VAL2 : ARR := (C, C);

          VAL3 : T RENAMES C;
     BEGIN
          NULL;
     END;

     NULL;
END C74306A;