c32001b.ada

来自「linux下编程用 编译软件」· ADA 代码 · 共 250 行

-- C32001B.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 IN MULTIPLE OBJECT DECLARATIONS FOR ARRAY 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.

-- HISTORY:
--     RJW 07/16/86  CREATED ORIGINAL TEST.
--     BCB 08/18/87  CHANGED HEADER TO STANDARD HEADER FORMAT.  CHANGED
--                   COMMENTS FOR S4 AND CS4 TO READ THAT THE BOUNDS ARE
--                   1 .. 6 AND THE COMPONENT TYPE ARR IS 1 .. 5.

WITH REPORT; USE REPORT;

PROCEDURE C32001B IS

     TYPE ARR IS ARRAY (NATURAL RANGE <>) OF INTEGER;

     BUMP : ARRAY (1 .. 4) OF INTEGER := (0, 0, 0, 0);

     FUNCTION F (I : INTEGER) RETURN INTEGER IS
     BEGIN
          BUMP (I) := BUMP (I) + 1;
          RETURN BUMP (I);
     END F;

BEGIN
     TEST ("C32001B", "CHECK THAT IN MULTIPLE OBJECT DECLARATIONS " &
                      "FOR ARRAY 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

          S1, S2   : ARR (1 .. F (1)) := (OTHERS => F (1));
          CS1, CS2 : CONSTANT ARR (1 .. F (2)) := (OTHERS => F (2));

          PROCEDURE CHECK (A, B : ARR; STR1, STR2 : STRING) IS
          BEGIN
               IF A'LAST /= 1 THEN
                    FAILED ( "INCORRECT UPPER BOUND FOR " & STR1 );
               END IF;

               IF A (1) /= 2 THEN
                    FAILED ( "INCORRECT INITIAL VALUE FOR " & STR1 );
               END IF;

               IF B'LAST /= 3 THEN
                    FAILED ( "INCORRECT UPPER BOUND FOR " & STR2 );
               END IF;

               BEGIN
                    IF B (1 .. 3) = (4, 5, 6) THEN
                         COMMENT ( STR2 & " WAS INITIALIZED TO " &
                                   "(4, 5, 6)" );
                    ELSIF B (1 .. 3) = (5, 4, 6) THEN
                         COMMENT ( STR2 & " WAS INITIALIZED TO " &
                                   "(5, 4, 6)" );
                    ELSIF B (1 .. 3) = (4, 6, 5) THEN
                         COMMENT ( STR2 & " WAS INITIALIZED TO " &
                                   "(4, 6, 5)" );
                    ELSIF B (1 .. 3) = (6, 4, 5) THEN
                         COMMENT ( STR2 & " WAS INITIALIZED TO " &
                                   "(6, 4, 5)" );
                    ELSIF B (1 .. 3) = (6, 5, 4) THEN
                         COMMENT ( STR2 & " WAS INITIALIZED TO " &
                                   "(6, 5, 4)" );
                    ELSIF B (1 .. 3) = (5, 6, 4) THEN
                         COMMENT ( STR2 & " WAS INITIALIZED TO " &
                                   "(5, 6, 4)" );
                    ELSE
                         FAILED ( STR2 & " HAS INCORRECT INITIAL " &
                                  "VALUE" );
                    END IF;
               EXCEPTION
                    WHEN CONSTRAINT_ERROR =>
                         FAILED ( "CONSTRAINT_ERROR RAISED - " &
                                   STR2 );
                    WHEN OTHERS =>
                         FAILED ( "EXCEPTION RAISED - " &
                                   STR2 );
               END;
          END;

     BEGIN
          CHECK (S1, S2, "S1", "S2");
          CHECK (CS1, CS2, "CS1", "CS2");
     END;

     DECLARE

          S3, S4 : ARRAY (1 .. F (3)) OF ARR (1 .. F (3)) :=
                   (OTHERS => (OTHERS => F (3)));

          CS3, CS4 : CONSTANT ARRAY (1.. F (4)) OF
                     ARR (1 .. F (4)) :=
                     (OTHERS => (OTHERS => F (4)));
     BEGIN
          IF S3'LAST = 1 THEN
               IF S3 (1)'LAST = 2 THEN
                    COMMENT ( "S3 HAS BOUNDS 1 .. 1 AND " &
                              "COMPONENT TYPE ARR (1 .. 2)" );
                    IF S3 (1)(1 .. 2) = (3, 4) THEN
                         COMMENT ( "S3 HAS INITIAL VALUES " &
                                   "3 AND 4 - 1" );
                    ELSIF S3 (1)(1 .. 2) = (4, 3) THEN
                         COMMENT ( "S3 HAS INITIAL VALUES " &
                                   "4 AND 3 - 1" );
                    ELSE
                         FAILED ( "S3 HAS WRONG INITIAL VALUES - 1" );
                    END IF;
               ELSE
                    FAILED ( "S3 HAS WRONG COMPONENT TYPE - 1" );
               END IF;
          ELSIF S3'LAST = 2 THEN
               IF S3 (1)'LAST = 1 THEN
                    COMMENT ( "S3 HAS BOUNDS 1 .. 2 AND " &
                              "COMPONENT TYPE ARR (1 .. 1)" );
                    IF S3 (1) (1) = 3 AND S3 (2) (1) = 4 THEN
                         COMMENT ( "S3 HAS INITIAL VALUES " &
                                   "3 AND 4 - 2" );
                    ELSIF S3 (1) (1) = 4 AND S3 (2) (1) = 3 THEN
                         COMMENT ( "S3 HAS INITIAL VALUES " &
                                   "4 AND 3 - 2" );
                    ELSE
                         FAILED ( "S3 HAS WRONG INITIAL VALUES - 2" );
                    END IF;
               ELSE
                    FAILED ( "S3 HAS WRONG COMPONENT TYPE - 2" );
               END IF;
          ELSE
               FAILED ( "S3 HAS INCORRECT BOUNDS" );
          END IF;

          IF S4'LAST = 5 THEN
               IF S4 (1)'LAST = 6 THEN
                    COMMENT ( "S4 HAS BOUNDS 1 .. 5 AND " &
                              "COMPONENT TYPE ARR (1 .. 6)" );
               ELSE
                    FAILED ( "S4 HAS WRONG COMPONENT TYPE - 1" );
               END IF;
          ELSIF S4'LAST = 6 THEN
               IF S4 (1)'FIRST = 1 AND S4 (1)'LAST = 5 THEN
                    COMMENT ( "S4 HAS BOUNDS 1 .. 6 AND " &
                              "COMPONENT TYPE ARR (1 .. 5)" );
               ELSE
                    FAILED ( "S4 HAS WRONG COMPONENT TYPE - 2" );
               END IF;
          ELSE
               FAILED ( "S4 HAS INCORRECT BOUNDS" );
          END IF;

          IF BUMP (3) /= 36 THEN
               FAILED ( "FUNCTION F NOT INVOKED CORRECT NUMBER OF " &
                        "TIMES TO INITIALIZE S4" );
          END IF;

          IF CS3'FIRST = 1 AND CS3'LAST = 1 THEN
               IF CS3 (1)'FIRST = 1 AND CS3 (1)'LAST = 2 THEN
                    COMMENT ( "CS3 HAS BOUNDS 1 .. 1 AND " &
                              "COMPONENT TYPE ARR (1 .. 2)" );
                    IF CS3 (1)(1 .. 2) = (3, 4) THEN
                         COMMENT ( "CS3 HAS INITIAL VALUES " &
                                   "3 AND 4 - 1" );
                    ELSIF CS3 (1)(1 .. 2) = (4, 3) THEN
                         COMMENT ( "CS3 HAS INITIAL VALUES " &
                                   "4 AND 3 - 1" );
                    ELSE
                         FAILED ( "CS3 HAS WRONG INITIAL VALUES - 1" );
                    END IF;
               ELSE
                    FAILED ( "CS3 HAS WRONG COMPONENT TYPE - 1" );
               END IF;
          ELSIF CS3'FIRST = 1 AND CS3'LAST = 2 THEN
               IF CS3 (1)'FIRST = 1 AND CS3 (1)'LAST = 1 THEN
                    COMMENT ( "CS3 HAS BOUNDS 1 .. 2 AND " &
                              "COMPONENT TYPE ARR (1 .. 1)" );
                    IF CS3 (1) (1) = 3 AND CS3 (2) (1) = 4 THEN
                         COMMENT ( "CS3 HAS INITIAL VALUES " &
                                   "3 AND 4 - 2" );
                    ELSIF CS3 (1) (1) = 4 AND CS3 (2) (1) = 3 THEN
                         COMMENT ( "CS3 HAS INITIAL VALUES " &
                                   "4 AND 3 - 2" );
                    ELSE
                         FAILED ( "CS3 HAS WRONG INITIAL VALUES - 2" );
                    END IF;
               ELSE
                    FAILED ( "CS3 HAS WRONG COMPONENT TYPE - 2" );
               END IF;
          ELSE
               FAILED ( "CS3 HAS INCORRECT BOUNDS" );
          END IF;

          IF CS4'FIRST = 1 AND CS4'LAST = 5 THEN
               IF CS4 (1)'FIRST = 1 AND CS4 (1)'LAST = 6 THEN
                    COMMENT ( "CS4 HAS BOUNDS 1 .. 5 AND " &
                              "COMPONENT TYPE ARR (1 .. 6)" );
               ELSE
                    FAILED ( "CS4 HAS WRONG COMPONENT TYPE - 1" );
               END IF;
          ELSIF CS4'FIRST = 1 AND CS4'LAST = 6 THEN
               IF CS4 (1)'FIRST = 1 AND CS4 (1)'LAST = 5 THEN
                    COMMENT ( "CS4 HAS BOUNDS 1 .. 6 AND " &
                              "COMPONENT TYPE ARR (1 .. 5)" );
               ELSE
                    FAILED ( "CS4 HAS WRONG COMPONENT TYPE - 2" );
               END IF;
          ELSE
               FAILED ( "CS4 HAS INCORRECT BOUNDS" );
          END IF;

          IF BUMP (4) /= 36 THEN
               FAILED ( "FUNCTION F NOT INVOKED CORRECT NUMBER OF " &
                        "TIMES TO INITIALIZE CS4" );
          END IF;
     END;

     RESULT;
END C32001B;