c32001e.ada

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

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