c36204d.ada

来自「linux下编程用 编译软件」· ADA 代码 · 共 599 行 · 第 1/2 页

-- C36204D.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 EACH ARRAY ATTRIBUTE YIELDS THE CORRECT VALUES.
-- BOTH ARRAY OBJECTS AND TYPES ARE CHECKED. THIS TEST CHECKS 
-- THE ABOVE FOR ARRAYS WITHIN GENERIC PROGRAM UNITS.

-- HISTROY
--  EDWARD V. BERARD, 9 AUGUST 1990

WITH REPORT ;
WITH SYSTEM ;

PROCEDURE C36204D 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) ;
    
    TYPE MONTH_TYPE IS (JAN, FEB, MAR, APR, MAY, JUN, JUL, AUG,
                        SEP, OCT, NOV, DEC) ;
    SUBTYPE MID_YEAR IS MONTH_TYPE RANGE MAY .. AUG ;
    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   => 10,
                             YEAR  => 1990) ;
                            
    FIRST_DATE     : DATE := (DAY   => 6,
                              MONTH => JUN,
                              YEAR  => 1967) ;
                            
    FUNCTION "=" (LEFT  : IN SYSTEM.ADDRESS ;
                  RIGHT : IN SYSTEM.ADDRESS ) RETURN BOOLEAN
            RENAMES SYSTEM."=" ;

    GENERIC
    
        TYPE FIRST_INDEX IS (<>) ;
        FIRST_INDEX_LENGTH : IN NATURAL ;
        FIRST_TEST_VALUE : IN FIRST_INDEX ;
        TYPE SECOND_INDEX IS (<>) ;
        SECOND_INDEX_LENGTH : IN NATURAL ;
        SECOND_TEST_VALUE : IN SECOND_INDEX ;
        TYPE THIRD_INDEX IS (<>) ;
        THIRD_INDEX_LENGTH : IN NATURAL ;
        THIRD_TEST_VALUE : IN THIRD_INDEX ;
        TYPE FIRST_COMPONENT_TYPE IS PRIVATE ;
        FIRST_DEFAULT_VALUE : IN FIRST_COMPONENT_TYPE ;
        SECOND_DEFAULT_VALUE : IN FIRST_COMPONENT_TYPE ;
        TYPE SECOND_COMPONENT_TYPE IS PRIVATE ;
        THIRD_DEFAULT_VALUE : IN SECOND_COMPONENT_TYPE ;
        FOURTH_DEFAULT_VALUE : IN SECOND_COMPONENT_TYPE ;
    
    PACKAGE ARRAY_ATTRIBUTE_TEST IS
    
        TYPE MATRIX IS ARRAY (FIRST_INDEX, SECOND_INDEX)
            OF FIRST_COMPONENT_TYPE ;
            
        TYPE CUBE IS ARRAY (FIRST_INDEX, SECOND_INDEX, THIRD_INDEX)
            OF SECOND_COMPONENT_TYPE ;
            
    END ARRAY_ATTRIBUTE_TEST ;
    
    PACKAGE BODY ARRAY_ATTRIBUTE_TEST IS
    
        FIRST_ARRAY : MATRIX := (FIRST_INDEX'FIRST .. FIRST_INDEX'LAST =>
                                (SECOND_INDEX'FIRST .. SECOND_INDEX'LAST =>
                                    FIRST_DEFAULT_VALUE)) ;
        
        SECOND_ARRAY : CUBE := (FIRST_INDEX'FIRST .. FIRST_INDEX'LAST =>
                               (SECOND_INDEX'FIRST .. SECOND_INDEX'LAST =>
                               (THIRD_INDEX'FIRST .. THIRD_INDEX'LAST =>
                                       THIRD_DEFAULT_VALUE))) ;
                                    
        THIRD_ARRAY : CONSTANT MATRIX 
                             := (FIRST_INDEX'FIRST .. FIRST_INDEX'LAST =>
                                (SECOND_INDEX'FIRST .. SECOND_INDEX'LAST =>
                                    SECOND_DEFAULT_VALUE)) ;
                                        
        FOURTH_ARRAY : CONSTANT CUBE 
                            := (FIRST_INDEX'FIRST .. FIRST_INDEX'LAST =>
                               (SECOND_INDEX'FIRST .. SECOND_INDEX'LAST =>
                               (THIRD_INDEX'FIRST .. THIRD_INDEX'LAST =>
                                       FOURTH_DEFAULT_VALUE))) ;
                                    
        FA1 : FIRST_INDEX := FIRST_ARRAY'FIRST (1) ;
        FA2 : FIRST_INDEX := FIRST_ARRAY'LAST (1) ;
        FA3 : SECOND_INDEX := FIRST_ARRAY'FIRST (2) ;
        FA4 : SECOND_INDEX := FIRST_ARRAY'LAST (2) ;
        
        SA1 : FIRST_INDEX := SECOND_ARRAY'FIRST (1) ;
        SA2 : FIRST_INDEX := SECOND_ARRAY'LAST (1) ;
        SA3 : SECOND_INDEX := SECOND_ARRAY'FIRST (2) ;
        SA4 : SECOND_INDEX := SECOND_ARRAY'LAST (2) ;
        SA5 : THIRD_INDEX := SECOND_ARRAY'FIRST (3) ;
        SA6 : THIRD_INDEX := SECOND_ARRAY'LAST (3) ;
        
        FAL1 : NATURAL := FIRST_ARRAY'LENGTH (1) ;
        FAL2 : NATURAL := FIRST_ARRAY'LENGTH (2) ;
        
        SAL1 : NATURAL := SECOND_ARRAY'LENGTH (1) ;
        SAL2 : NATURAL := SECOND_ARRAY'LENGTH (2) ;
        SAL3 : NATURAL := SECOND_ARRAY'LENGTH (3) ;
        
        MATRIX_SIZE : NATURAL := MATRIX'SIZE ;
        CUBE_SIZE    : NATURAL := CUBE'SIZE ;
        
        FAA  : SYSTEM.ADDRESS := FIRST_ARRAY'ADDRESS ;
        SAA  : SYSTEM.ADDRESS := SECOND_ARRAY'ADDRESS ;
        TAA  : SYSTEM.ADDRESS := THIRD_ARRAY'ADDRESS ;
        FRAA : SYSTEM.ADDRESS := FOURTH_ARRAY'ADDRESS ;
             
     BEGIN  -- ARRAY_ATTRIBUTE_TEST
     
        IF (FA1 /= FIRST_INDEX'FIRST) OR
           (FA3 /= SECOND_INDEX'FIRST) OR
           (SA1 /= FIRST_INDEX'FIRST) OR
           (SA3 /= SECOND_INDEX'FIRST) OR
           (SA5 /= THIRD_INDEX'FIRST) THEN
            REPORT.FAILED ("INCORRECT VALUE RETURNED FOR 'FIRST - PACKAGE") ;
        END IF ;
        
        IF (FA2 /= FIRST_INDEX'LAST) OR
           (FA4 /= SECOND_INDEX'LAST) OR
           (SA2 /= FIRST_INDEX'LAST) OR
           (SA4 /= SECOND_INDEX'LAST) OR
           (SA6 /= THIRD_INDEX'LAST) THEN
            REPORT.FAILED ("INCORRECT VALUE RETURNED FOR 'LAST - PACKAGE") ;
        END IF ;
        
        IF (FAL1 /= FIRST_INDEX_LENGTH) OR
           (FAL2 /= SECOND_INDEX_LENGTH) OR
           (SAL1 /= FIRST_INDEX_LENGTH) OR
           (SAL2 /= SECOND_INDEX_LENGTH) OR
           (SAL3 /= THIRD_INDEX_LENGTH) THEN
            REPORT.FAILED ("INCORRECT VALUE RETURNED FOR 'LENGTH - PACKAGE") ;
        END IF ;
        
        FOR OUTER_INDEX IN FIRST_ARRAY'RANGE (1) LOOP
            FOR INNER_INDEX IN FIRST_ARRAY'RANGE (2) LOOP
                FIRST_ARRAY (OUTER_INDEX, INNER_INDEX) :=
                    SECOND_DEFAULT_VALUE ;
            END LOOP ;
        END LOOP ;
        
        IF FIRST_ARRAY /= THIRD_ARRAY THEN
            REPORT.FAILED ("INCORRECT HANDLING OF 'RANGE ATTRIBUTE " &
                           "FOR 2-DIMENSIONAL ARRAY. - PACKAGE") ;
        END IF ;
        
        FOR OUTER_INDEX IN SECOND_ARRAY'RANGE (1) LOOP
            FOR MIDDLE_INDEX IN SECOND_ARRAY'RANGE (2) LOOP
                FOR INNER_INDEX IN SECOND_ARRAY'RANGE (3) LOOP
                    SECOND_ARRAY (OUTER_INDEX, MIDDLE_INDEX, INNER_INDEX)
                        := FOURTH_DEFAULT_VALUE ;
                END LOOP ;
            END LOOP ;
        END LOOP ;
        
        IF SECOND_ARRAY /= FOURTH_ARRAY THEN
            REPORT.FAILED ("INCORRECT HANDLING OF 'RANGE ATTRIBUTE " &
                           "FOR 3-DIMENSIONAL ARRAY. - PACKAGE") ;
        END IF ;
        
        IF (FIRST_TEST_VALUE NOT IN FIRST_ARRAY'RANGE (1)) OR
           (FIRST_TEST_VALUE NOT IN SECOND_ARRAY'RANGE (1)) OR
           (SECOND_TEST_VALUE NOT IN FIRST_ARRAY'RANGE (2)) OR
           (SECOND_TEST_VALUE NOT IN SECOND_ARRAY'RANGE (2)) OR
           (THIRD_TEST_VALUE NOT IN SECOND_ARRAY'RANGE (3)) THEN
            REPORT.FAILED ("INCORRECT HANDLING OF 'RANGE ATTRIBUTE " &
                           "- PACKAGE") ;
        END IF ;
        
        IF (MATRIX_SIZE = 0) OR (CUBE_SIZE = 0) THEN
            REPORT.FAILED ("INCORRECT HANDLING OF THE 'SIZE ATTRIBUTE. " &
                           "- PACKAGE") ;
        END IF ;
        
        IF (FAA = TAA) OR (SAA = FRAA) OR (FAA = SAA) OR (FAA = FRAA)
           OR (SAA = TAA) OR (TAA = FRAA) THEN
            REPORT.FAILED ("INCORRECT HANDLING OF THE 'ADDRESS ATTRIBUTE. " &
                           "- PACKAGE") ;
        END IF ;
        
    END ARRAY_ATTRIBUTE_TEST ;

    GENERIC
    
        TYPE FIRST_INDEX IS (<>) ;
        FIRST_INDEX_LENGTH : IN NATURAL ;
        FIRST_TEST_VALUE : IN FIRST_INDEX ;
        TYPE SECOND_INDEX IS (<>) ;
        SECOND_INDEX_LENGTH : IN NATURAL ;
        SECOND_TEST_VALUE : IN SECOND_INDEX ;
        TYPE THIRD_INDEX IS (<>) ;
        THIRD_INDEX_LENGTH : IN NATURAL ;
        THIRD_TEST_VALUE : IN THIRD_INDEX ;
        TYPE FIRST_COMPONENT_TYPE IS PRIVATE ;
        FIRST_DEFAULT_VALUE : IN FIRST_COMPONENT_TYPE ;
        SECOND_DEFAULT_VALUE : IN FIRST_COMPONENT_TYPE ;
        TYPE SECOND_COMPONENT_TYPE IS PRIVATE ;
        THIRD_DEFAULT_VALUE : IN SECOND_COMPONENT_TYPE ;
        FOURTH_DEFAULT_VALUE : IN SECOND_COMPONENT_TYPE ;
        
    PROCEDURE PROC_ARRAY_ATT_TEST ;
    
    PROCEDURE PROC_ARRAY_ATT_TEST IS
    
        TYPE MATRIX IS ARRAY (FIRST_INDEX, SECOND_INDEX)
            OF FIRST_COMPONENT_TYPE ;
            
        TYPE CUBE IS ARRAY (FIRST_INDEX, SECOND_INDEX, THIRD_INDEX)
            OF SECOND_COMPONENT_TYPE ;
            
        FIRST_ARRAY : MATRIX := (FIRST_INDEX'FIRST .. FIRST_INDEX'LAST =>
                                (SECOND_INDEX'FIRST .. SECOND_INDEX'LAST =>
                                    FIRST_DEFAULT_VALUE)) ;
        
        SECOND_ARRAY : CUBE := (FIRST_INDEX'FIRST .. FIRST_INDEX'LAST =>
                               (SECOND_INDEX'FIRST .. SECOND_INDEX'LAST =>
                               (THIRD_INDEX'FIRST .. THIRD_INDEX'LAST =>
                                       THIRD_DEFAULT_VALUE))) ;
                                    
        THIRD_ARRAY : CONSTANT MATRIX 
                             := (FIRST_INDEX'FIRST .. FIRST_INDEX'LAST =>
                                (SECOND_INDEX'FIRST .. SECOND_INDEX'LAST =>
                                    SECOND_DEFAULT_VALUE)) ;
                                        
        FOURTH_ARRAY : CONSTANT CUBE 
                            := (FIRST_INDEX'FIRST .. FIRST_INDEX'LAST =>
                               (SECOND_INDEX'FIRST .. SECOND_INDEX'LAST =>
                               (THIRD_INDEX'FIRST .. THIRD_INDEX'LAST =>
                                       FOURTH_DEFAULT_VALUE))) ;
                                    
        FA1 : FIRST_INDEX := FIRST_ARRAY'FIRST (1) ;
        FA2 : FIRST_INDEX := FIRST_ARRAY'LAST (1) ;
        FA3 : SECOND_INDEX := FIRST_ARRAY'FIRST (2) ;
        FA4 : SECOND_INDEX := FIRST_ARRAY'LAST (2) ;
        
        SA1 : FIRST_INDEX := SECOND_ARRAY'FIRST (1) ;
        SA2 : FIRST_INDEX := SECOND_ARRAY'LAST (1) ;
        SA3 : SECOND_INDEX := SECOND_ARRAY'FIRST (2) ;
        SA4 : SECOND_INDEX := SECOND_ARRAY'LAST (2) ;
        SA5 : THIRD_INDEX := SECOND_ARRAY'FIRST (3) ;
        SA6 : THIRD_INDEX := SECOND_ARRAY'LAST (3) ;
        
        FAL1 : NATURAL := FIRST_ARRAY'LENGTH (1) ;
        FAL2 : NATURAL := FIRST_ARRAY'LENGTH (2) ;
        
        SAL1 : NATURAL := SECOND_ARRAY'LENGTH (1) ;
        SAL2 : NATURAL := SECOND_ARRAY'LENGTH (2) ;
        SAL3 : NATURAL := SECOND_ARRAY'LENGTH (3) ;
        
        MATRIX_SIZE : NATURAL := MATRIX'SIZE ;
        CUBE_SIZE    : NATURAL := CUBE'SIZE ;
        
        FAA : SYSTEM.ADDRESS := FIRST_ARRAY'ADDRESS ;
        SAA : SYSTEM.ADDRESS := SECOND_ARRAY'ADDRESS ;
        TAA : SYSTEM.ADDRESS := THIRD_ARRAY'ADDRESS ;
        FRAA : SYSTEM.ADDRESS := FOURTH_ARRAY'ADDRESS ;
             
     BEGIN  -- PROC_ARRAY_ATT_TEST

        IF (FA1 /= FIRST_INDEX'FIRST) OR
           (FA3 /= SECOND_INDEX'FIRST) OR
           (SA1 /= FIRST_INDEX'FIRST) OR
           (SA3 /= SECOND_INDEX'FIRST) OR
           (SA5 /= THIRD_INDEX'FIRST) THEN
            REPORT.FAILED ("INCORRECT VALUE RETURNED FOR 'FIRST " &
                           "- PROCEDURE") ;
        END IF ;