cc3224a.ada

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

-- CC3224A.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 A FORMAL ARRAY TYPE DENOTES ITS ACTUAL
--     PARAMETER, AND THAT OPERATIONS OF THE FORMAL TYPE ARE THOSE
--     IDENTIFIED WITH THE CORRESPONDING OPERATIONS OF THE ACTUAL TYPE.

-- HISTORY:
--     DHH 09/19/88  CREATED ORIGINAL TEST.
--     EDWARD V. BERARD, 14 AUGUST 1990  ADDED CHECKS FOR MULTI-
--                                       DIMENSIONAL ARRAYS
--     PWN 11/30/94 REMOVED 'BASE USE ILLEGAL IN ADA 9X.

WITH REPORT ;

PROCEDURE CC3224A IS

    SUBTYPE INT IS INTEGER RANGE 1 .. 3;
    TYPE ARR IS ARRAY(1 .. 3) OF INTEGER;
    TYPE B_ARR IS ARRAY(1 .. 3) OF BOOLEAN;

    Q : ARR;
    R : B_ARR;
     
    GENERIC
        TYPE T IS ARRAY(INT) OF INTEGER;
    PACKAGE P IS
        SUBTYPE SUB_T IS T;
        X : SUB_T := (1, 2, 3);
    END P;

    GENERIC
        TYPE T IS ARRAY(INT) OF BOOLEAN;
    PACKAGE BOOL IS
        SUBTYPE SUB_T IS T;
    END BOOL;
     
    SHORT_START : CONSTANT := -100 ;
    SHORT_END   : CONSTANT := 100 ;
    TYPE SHORT_RANGE IS RANGE SHORT_START .. SHORT_END ;
    
    SUBTYPE REALLY_SHORT IS SHORT_RANGE RANGE -9 .. 0 ;
    
    TYPE MONTH_TYPE IS (JAN, FEB, MAR, APR, MAY, JUN, JUL, AUG,
                        SEP, OCT, NOV, DEC) ;
                        
    SUBTYPE FIRST_HALF IS MONTH_TYPE RANGE JAN .. JUN ;
    
    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 := (MONTH => AUG,
                             DAY   => 8,
                             YEAR  => 1990) ;
                            
    FIRST_DATE    : DATE := (DAY   => 6,
                             MONTH => JUN,
                             YEAR  => 1967) ;
                            
    WALL_DATE     : DATE := (MONTH => NOV,
                             DAY   => 9,
                             YEAR  => 1989) ;
                            
    SUBTYPE FIRST_FIVE IS CHARACTER RANGE 'A' .. 'E' ;
                            
    TYPE THREE_DIMENSIONAL IS ARRAY (REALLY_SHORT,
                                     FIRST_HALF,
                                     FIRST_FIVE) OF DATE ;
                                     
    TD_ARRAY        : THREE_DIMENSIONAL ;
    SECOND_TD_ARRAY : THREE_DIMENSIONAL ;
                                     
    GENERIC
    
        TYPE CUBE IS ARRAY (REALLY_SHORT,
                            FIRST_HALF,
                            FIRST_FIVE) OF DATE ;
                            
    PACKAGE TD_ARRAY_PACKAGE IS
    
        SUBTYPE SUB_CUBE IS CUBE ;
        TEST_3D_ARRAY : SUB_CUBE := (THREE_DIMENSIONAL'RANGE =>
                                    (THREE_DIMENSIONAL'RANGE (2) =>
                                    (THREE_DIMENSIONAL'RANGE (3) =>
                                     TODAY))) ;
                                     
    END TD_ARRAY_PACKAGE ;


BEGIN  -- CC3224A

    REPORT.TEST ("CC3224A", "CHECK THAT A FORMAL ARRAY TYPE DENOTES " &
                 "ITS ACTUAL PARAMETER, AND THAT OPERATIONS OF " &
                 "THE FORMAL TYPE ARE THOSE IDENTIFIED WITH THE " &
                 "CORRESPONDING OPERATIONS OF THE ACTUAL TYPE");

    ONE_DIMENSIONAL:
     
    DECLARE

        PACKAGE P1 IS NEW P (ARR);

        TYPE NEW_T IS NEW P1.SUB_T;
        OBJ_NEWT : NEW_T;
          
    BEGIN  -- ONE_DIMENSIONAL
     
        IF NEW_T'FIRST /= ARR'FIRST THEN
            REPORT.FAILED("'FIRST ATTRIBUTE REPORT.FAILED");
        END IF;
          
        IF NEW_T'LAST /= ARR'LAST THEN
            REPORT.FAILED("'LAST ATTRIBUTE REPORT.FAILED");
        END IF;
          
        IF NEW_T'FIRST(1) /= ARR'FIRST(1) THEN
            REPORT.FAILED("'FIRST(N) ATTRIBUTE REPORT.FAILED");
        END IF;
          
        IF NOT (NEW_T'LAST(1) = ARR'LAST(1)) THEN
            REPORT.FAILED("'LAST(N) ATTRIBUTE REPORT.FAILED");
        END IF;
          
        IF 2 NOT IN NEW_T'RANGE THEN
            REPORT.FAILED("'RANGE ATTRIBUTE REPORT.FAILED");
        END IF;
          
        IF 3 NOT IN NEW_T'RANGE(1) THEN
            REPORT.FAILED("'RANGE(N) ATTRIBUTE REPORT.FAILED");
        END IF;
          
        IF NEW_T'LENGTH /= ARR'LENGTH THEN
            REPORT.FAILED("'LENGTH ATTRIBUTE REPORT.FAILED");
        END IF;
          
        IF NEW_T'LENGTH(1) /= ARR'LENGTH(1) THEN
            REPORT.FAILED("'LENGTH(N) ATTRIBUTE REPORT.FAILED");
         END IF;
           
        OBJ_NEWT := (1, 2, 3);
        IF REPORT.IDENT_INT(3) /= OBJ_NEWT(3) THEN
            REPORT.FAILED("ASSIGNMENT REPORT.FAILED");
        END IF;

        IF NEW_T'(1, 2, 3) NOT IN NEW_T THEN
            REPORT.FAILED("QUALIFIED EXPRESSION REPORT.FAILED");
        END IF;

        Q := (1, 2, 3);
        IF NEW_T(Q) /= OBJ_NEWT THEN
            REPORT.FAILED("EXPLICIT CONVERSION REPORT.FAILED");
        END IF;
        
        IF Q(1) /= OBJ_NEWT(1) THEN
            REPORT.FAILED("INDEXING REPORT.FAILED");
        END IF;
        
        IF (1, 2) /= OBJ_NEWT(1 .. 2) THEN
            REPORT.FAILED("SLICE REPORT.FAILED");
        END IF;
        
        IF (1, 2) & OBJ_NEWT(3) /= NEW_T(Q)THEN
            REPORT.FAILED("CATENATION REPORT.FAILED");
        END IF;
        
        IF NOT (P1.X IN ARR) THEN
            REPORT.FAILED ("FORMAL DOES NOT DENOTE ACTUAL");
        END IF;
          
    END ONE_DIMENSIONAL ;

    BOOLEAN_ONE_DIMENSIONAL:
     
    DECLARE

        PACKAGE B1 IS NEW BOOL (B_ARR);

        TYPE NEW_T IS NEW B1.SUB_T;
        OBJ_NEWT : NEW_T;
          
    BEGIN  -- BOOLEAN_ONE_DIMENSIONAL

        OBJ_NEWT := (TRUE, TRUE, TRUE);
        R := (TRUE, TRUE, TRUE);

        IF (NEW_T'((TRUE, TRUE, TRUE)) XOR OBJ_NEWT) /=
           NEW_T'((FALSE, FALSE, FALSE)) THEN
            REPORT.FAILED("XOR REPORT.FAILED - BOOLEAN") ;
        END IF;
        
        IF (NEW_T'((FALSE, FALSE, TRUE)) AND OBJ_NEWT) /=
           NEW_T'((FALSE, FALSE, TRUE)) THEN
            REPORT.FAILED("AND REPORT.FAILED - BOOLEAN") ;
        END IF;
        
        IF (NEW_T'((FALSE, FALSE, FALSE)) OR OBJ_NEWT) /=
           NEW_T'((TRUE, TRUE, TRUE)) THEN
            REPORT.FAILED("OR REPORT.FAILED - BOOLEAN") ;
        END IF ;
          
    END BOOLEAN_ONE_DIMENSIONAL ;
     
    THREE_DIMENSIONAL_TEST:
     
    DECLARE
     
         PACKAGE TD IS NEW TD_ARRAY_PACKAGE (CUBE => THREE_DIMENSIONAL) ;
        
        TYPE NEW_CUBE IS NEW TD.SUB_CUBE ;
        NEW_CUBE_OBJECT : NEW_CUBE ;
        
    BEGIN  -- THREE_DIMENSIONAL_TEST
    
        IF (NEW_CUBE'FIRST /= THREE_DIMENSIONAL'FIRST) OR
           (NEW_CUBE'FIRST (1) /= THREE_DIMENSIONAL'FIRST) OR
           (NEW_CUBE'FIRST (2) /= THREE_DIMENSIONAL'FIRST (2)) OR
           (NEW_CUBE'FIRST (3) /= THREE_DIMENSIONAL'FIRST (3)) THEN
            REPORT.FAILED ("PROBLEMS WITH 'FIRST FOR MULTI-" &
                           "DIMENSIONAL ARRAYS.") ;
        END IF ;
        
        IF (NEW_CUBE'LAST /= THREE_DIMENSIONAL'LAST) OR
           (NEW_CUBE'LAST (1) /= THREE_DIMENSIONAL'LAST) OR
           (NEW_CUBE'LAST (2) /= THREE_DIMENSIONAL'LAST (2)) OR
           (NEW_CUBE'LAST (3) /= THREE_DIMENSIONAL'LAST (3)) THEN
            REPORT.FAILED ("PROBLEMS WITH 'LAST FOR MULTI-" &
                           "DIMENSIONAL ARRAYS.") ;
        END IF ;
        
        IF (-5 NOT IN NEW_CUBE'RANGE) OR
           (-3 NOT IN NEW_CUBE'RANGE (1)) OR
           (FEB NOT IN NEW_CUBE'RANGE (2)) OR
           ('C' NOT IN NEW_CUBE'RANGE (3)) THEN
            REPORT.FAILED ("PROBLEMS WITH 'RANGE FOR MULTI-" &
                           "DIMENSIONAL ARRAYS.") ;
        END IF ;
        
        IF (NEW_CUBE'LENGTH /= THREE_DIMENSIONAL'LENGTH) OR
           (NEW_CUBE'LENGTH (1) /= THREE_DIMENSIONAL'LENGTH) OR
           (NEW_CUBE'LENGTH (2) /= THREE_DIMENSIONAL'LENGTH (2)) OR
           (NEW_CUBE'LENGTH (3) /= THREE_DIMENSIONAL'LENGTH (3)) THEN
            REPORT.FAILED ("PROBLEMS WITH 'LENGTH FOR MULTI-" &
                           "DIMENSIONAL ARRAYS.") ;
        END IF ;
        
        NEW_CUBE_OBJECT := (NEW_CUBE'RANGE =>
                           (NEW_CUBE'RANGE (2) =>
                           (NEW_CUBE'RANGE (3) =>
                            FIRST_DATE))) ;
        IF FIRST_DATE /= NEW_CUBE_OBJECT (-3, MAR, 'D') THEN
            REPORT.FAILED ("ASSIGNMENT FOR MULTI-DIMENSIONAL " &
                           "ARRAYS FAILED.") ;
        END IF ;
        
        IF NEW_CUBE'(NEW_CUBE'RANGE =>
                    (NEW_CUBE'RANGE (2) =>
                    (NEW_CUBE'RANGE (3) =>
                     WALL_DATE))) NOT IN NEW_CUBE THEN
            REPORT.FAILED ("QUALIFIED EXPRESSION FOR MULTI-" &
                           "DIMENSIONAL ARRAYS FAILED.") ;
        END IF ;
        
        SECOND_TD_ARRAY := (NEW_CUBE'RANGE =>
                           (NEW_CUBE'RANGE (2) =>
                           (NEW_CUBE'RANGE (3) =>
                            FIRST_DATE))) ;
        IF NEW_CUBE (SECOND_TD_ARRAY) /= NEW_CUBE_OBJECT THEN
            REPORT.FAILED ("EXPLICIT CONVERSION FOR MULTI-" &
                           "DIMENSIONAL ARRAYS FAILED.") ;
        END IF ;
        
        IF SECOND_TD_ARRAY (-2, FEB, 'B')
            /= NEW_CUBE_OBJECT (-2, FEB, 'B') THEN
            REPORT.FAILED ("INDEXING FOR MULTI-" &
                           "DIMENSIONAL ARRAYS FAILED.") ;
        END IF ;
        
        IF NOT (TD.TEST_3D_ARRAY IN THREE_DIMENSIONAL) THEN
            REPORT.FAILED ("FORMAL MULTI-DIMENSIONAL ARRAY " &
                           "DOES NOT DENOTE ACTUAL.") ;
        END IF ;
        
    END THREE_DIMENSIONAL_TEST ;
    
    REPORT.RESULT ;
     
END CC3224A ;