cc1224a.ada

来自「用于进行gcc测试」· ADA 代码 · 共 559 行 · 第 1/2 页

-- CC1224A.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:
--     FOR ARRAY TYPES WITH A NONLIMITED COMPONENT TYPE (OF A FORMAL
--     AND NONFORMAL GENERIC TYPE), CHECK THAT THE FOLLOWING OPERATIONS
--     ARE IMPLICITY DECLARED AND ARE, THEREFORE, AVAILABLE WITHIN THE
--     GENERIC UNIT: ASSIGNMENT, THE OPERATION ASSOCIATED WITH
--     AGGREGATE NOTATION, MEMBERSHIP TESTS, THE OPERATION ASSOCIATED
--     WITH INDEXED COMPONENTS, QUALIFICATION, EXPLICIT CONVERSION,
--     'SIZE, 'ADDRESS, 'FIRST, 'FIRST (N), 'LAST, 'LAST (N),
--     'RANGE, 'RANGE (N), 'LENGTH, 'LENGTH (N).

-- HISTORY:
--     R.WILLIAMS  10/6/86
--     EDWARD V. BERARD  8/10/90  ADDED CHECKS FOR MULTI-DIMENSIONAL
--                                ARRAYS
--     LDC  10/10/90  CHANGED DECLARATIONS OF AD1 - AD6 TO PROCEDURE
--                    CALLS OF FA1 - FA6 TO ADDRESS_CHECK AS SUGGESTED
--                    BY THE CRG. 
--     PWN  01/31/95  REMOVED INCONSISTENCIES WITH ADA 9X.

WITH SYSTEM ;
WITH REPORT ;

PROCEDURE CC1224A IS

     SHORT_START : CONSTANT := -10 ;
     SHORT_END   : CONSTANT := 10 ;

     TYPE SHORT_RANGE IS RANGE SHORT_START .. SHORT_END ;
     SHORT_LENGTH : CONSTANT NATURAL := (SHORT_END - SHORT_START + 1) ;

     MEDIUM_START    : CONSTANT := 1 ;
     MEDIUM_END      : CONSTANT := 15 ;

     TYPE MEDIUM_RANGE IS RANGE MEDIUM_START .. MEDIUM_END ;
     MEDIUM_LENGTH   : CONSTANT NATURAL := 
                                (MEDIUM_END - MEDIUM_START + 1) ;

     TYPE MONTH_TYPE IS (JAN, FEB, MAR, APR, MAY, JUN, JUL, AUG,
                         SEP, OCT, NOV, DEC) ;
     TYPE DAY_TYPE IS RANGE 1 .. 31 ;
     TYPE YEAR_TYPE IS RANGE 1904 .. 2050 ;
     TYPE DATE IS RECORD
          MONTH : MONTH_TYPE ;
          DAY   : DAY_TYPE ;
          YEAR  : YEAR_TYPE ;
     END RECORD ;

     TODAY : DATE := (AUG, 10, 1990) ;

     TYPE FIRST_TEMPLATE IS ARRAY (SHORT_RANGE RANGE <>,
                                   MEDIUM_RANGE RANGE <>) OF DATE ;

     TYPE SECOND_TEMPLATE IS ARRAY (SHORT_RANGE, MEDIUM_RANGE) 
                                   OF DATE ;

     FIRST_ARRAY     : FIRST_TEMPLATE (-10 .. 10, 6 .. 10) ;
     SECOND_ARRAY    : FIRST_TEMPLATE (0 .. 7, 1 .. 15) ;
     THIRD_ARRAY     : SECOND_TEMPLATE ;
     FOURTH_ARRAY    : SECOND_TEMPLATE ;

     SUBTYPE SUBINT IS INTEGER RANGE REPORT.IDENT_INT (1) .. 
                                     REPORT.IDENT_INT (6);

     TYPE ARRA IS ARRAY (SUBINT) OF SUBINT;
     A1 : ARRA := (REPORT.IDENT_INT (1) .. REPORT.IDENT_INT (6) => 1);
     A2 : ARRA := (A1'RANGE => 2);

     TYPE ARRB IS ARRAY (SUBINT RANGE <>) OF DATE ;
     A3 : ARRB (1 .. 6) := 
               (REPORT.IDENT_INT (1) .. REPORT.IDENT_INT (6) => TODAY);

     TYPE ARRC IS ARRAY (SUBINT RANGE <>, SUBINT RANGE <>) OF SUBINT;
     A4 : CONSTANT ARRC := (1 .. 6 => (1 .. 6 => 4));

     TYPE ARRD IS ARRAY (SUBINT, SUBINT) OF SUBINT;
     A5 : ARRD := (A4'RANGE (1) => (A4'RANGE (2) => 5));

     TYPE ARRE IS ARRAY (SUBINT) OF DATE ;
     A6 : ARRE := (A1'RANGE => TODAY);

     FUNCTION "=" (LEFT  : IN SYSTEM.ADDRESS ;
                   RIGHT : IN SYSTEM.ADDRESS ) RETURN BOOLEAN
              RENAMES SYSTEM."=" ;

     GENERIC

          TYPE T1 IS (<>);
          TYPE T2 IS PRIVATE;
          X2 : T2;

          TYPE FARR1 IS ARRAY (SUBINT) OF T1;
          FA1 : FARR1;

          TYPE FARR2 IS ARRAY (SUBINT) OF SUBINT;
          FA2 : FARR2;

          TYPE FARR3 IS ARRAY (SUBINT RANGE <>) OF T2;
          FA3 : FARR3;

          TYPE FARR4 IS ARRAY (SUBINT RANGE <>, SUBINT RANGE <>) OF T1;
          FA4 : FARR4;

          TYPE FARR5 IS ARRAY (SUBINT, SUBINT) OF SUBINT;
          FA5 : FARR5;

          TYPE FARR6 IS ARRAY (T1) OF T2;
          FA6 : FARR6;

          TYPE FARR7 IS ARRAY (T1) OF T2;
          FA7 : FARR7;

     PROCEDURE P ;

     GENERIC

          TYPE FIRST_INDEX IS (<>) ;
          TYPE SECOND_INDEX IS (<>) ;
          TYPE UNCONSTRAINED_ARRAY IS ARRAY 
               (FIRST_INDEX RANGE <>, SECOND_INDEX RANGE <>) OF DATE ;

     PROCEDURE TEST_PROCEDURE (FIRST        : IN UNCONSTRAINED_ARRAY ;
                               FFIFS        : IN FIRST_INDEX ;
                               FFILS        : IN FIRST_INDEX ;
                               FSIFS        : IN SECOND_INDEX ;
                               FSILS        : IN SECOND_INDEX ;
                               FFLEN        : IN NATURAL ;
                               FSLEN        : IN NATURAL ;
                               FFIRT        : IN FIRST_INDEX ;
                               FSIRT        : IN SECOND_INDEX ;
                               SECOND       : IN UNCONSTRAINED_ARRAY ;
                               SFIFS        : IN FIRST_INDEX ;
                               SFILS        : IN FIRST_INDEX ;
                               SSIFS        : IN SECOND_INDEX ;
                               SSILS        : IN SECOND_INDEX ;
                               SFLEN        : IN NATURAL ;
                               SSLEN        : IN NATURAL ;
                               SFIRT        : IN FIRST_INDEX ;
                               SSIRT        : IN SECOND_INDEX ;
                               REMARKS      : IN STRING) ;
     GENERIC

          TYPE FIRST_INDEX IS (<>) ;
          TYPE SECOND_INDEX IS (<>) ;
          TYPE COMPONENT_TYPE IS PRIVATE ;
          TYPE CONSTRAINED_ARRAY IS ARRAY 
               (FIRST_INDEX,SECOND_INDEX) OF COMPONENT_TYPE ;

     PROCEDURE CTEST_PROCEDURE (FIRST        : IN CONSTRAINED_ARRAY ;
                                FFIRT        : IN FIRST_INDEX ;
                                FSIRT        : IN SECOND_INDEX ;
                                SECOND       : IN CONSTRAINED_ARRAY ;
                                SFIRT        : IN FIRST_INDEX ;
                                SSIRT        : IN SECOND_INDEX ;
                                REMARKS      : IN STRING) ;


     PROCEDURE P IS

          IN1 : INTEGER := FA1'SIZE;
          IN2 : INTEGER := FA2'SIZE;
          IN3 : INTEGER := FA3'SIZE;
          IN4 : INTEGER := FA4'SIZE;
          IN5 : INTEGER := FA5'SIZE;
          IN6 : INTEGER := FA6'SIZE;

          B1 : FARR1;

          B2 : FARR2;

          SUBTYPE SARR3 IS FARR3 (FA3'RANGE);
          B3 : SARR3;

          SUBTYPE SARR4 IS FARR4 (FA4'RANGE (1), FA4'RANGE (2));
          B4 : SARR4;

          B5 : FARR5;

          B6 : FARR6 ;

          PROCEDURE ADDRESS_CHECK(ADDRESS : SYSTEM.ADDRESS) IS

          BEGIN
               IF REPORT.EQUAL(1, REPORT.IDENT_INT(2)) THEN
                    REPORT.COMMENT("DON'T OPTIMIZE OUT ADDRESS_CHECK");
               END IF;
          END ADDRESS_CHECK;

     BEGIN  -- P

          ADDRESS_CHECK(FA1'ADDRESS);
          ADDRESS_CHECK(FA2'ADDRESS);
          ADDRESS_CHECK(FA3'ADDRESS);
          ADDRESS_CHECK(FA4'ADDRESS);
          ADDRESS_CHECK(FA5'ADDRESS);
          ADDRESS_CHECK(FA6'ADDRESS);

          B1 := FA1;

          IF B1 /= FARR1 (FA1) THEN
               REPORT.FAILED ("INCORRECT RESULTS - 1" );
          END IF;

          B2 := FA2;

          IF B2 /= FARR2 (A2) THEN
               REPORT.FAILED ("INCORRECT RESULTS - 2" );
          END IF;

          B3 := FA3;

          IF B3 /= FARR3 (FA3) THEN
               REPORT.FAILED ("INCORRECT RESULTS - 3" );
          END IF;

          B4 := FA4;

          IF B4 /= FARR4 (FA4) THEN
               REPORT.FAILED ("INCORRECT RESULTS - 4" );
          END IF;

          B5 := FA5;

          IF B5 /= FARR5 (A5) THEN
               REPORT.FAILED ("INCORRECT RESULTS - 5" );
          END IF;

          B6 := FA6;

          IF B6 /= FARR6 (FA6) THEN
               REPORT.FAILED ("INCORRECT RESULTS - 6" );
          END IF;

          IF FA7 /= FARR7 (FA6) THEN
               REPORT.FAILED ("INCORRECT RESULTS - 7" );
          END IF;

          B1 := FARR1'(FA1'RANGE => T1'VAL (1));

          IF B1 (1) /= FA1 (1) THEN
               REPORT.FAILED ("INCORRECT RESULTS - 8" );
          END IF;

          B1 := FARR1'(1 => T1'VAL (1), 2 => T1'VAL (1), 
                       3 .. 6 => T1'VAL (2));

          IF B1 (1) /= FA1 (1) THEN
               REPORT.FAILED ("INCORRECT RESULTS - 9" );
          END IF;

          B2 := FARR2'(FA2'RANGE => 2);

          IF B2 (2) /= FA2 (2) THEN
               REPORT.FAILED ("INCORRECT RESULTS - 10" );
          END IF;

          B3 := FARR3'(1|2|3 => X2, 4|5|6 => X2);