cc3016b.ada

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

-- CC3016B.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 AN INSTANCE OF A GENERIC PACKAGE MUST DECLARE A
--  PACKAGE. CHECK THAT THE DECLARATIVE ITEMS IN AN INSTANTIATION
--  OF A GENERIC PACKAGE SPECIFICATION ARE ELABORATED IN THE ORDER
--  DECLARED.    

-- HISTORY:
--         EDWARD V. BERARD, 8 AUGUST 1990

WITH REPORT ;

PROCEDURE CC3016B IS
     
    WHEN_ELABORATED : NATURAL := 0 ;
    
    TYPE REAL IS DIGITS 6 ;
    REAL_VALUE : REAL := 3.14159 ;
    
    TRUE_VALUE : BOOLEAN := TRUE ;
    
    CHARACTER_VALUE : CHARACTER := 'Z' ;
          
    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 ;
          
    TYPE DATE_ACCESS IS ACCESS DATE ;

    THIS_MONTH   : MONTH_TYPE := AUG ;
    THIS_YEAR     : YEAR_TYPE := 1990 ;

    TODAY         : DATE := (MONTH => AUG,
                               DAY   => 8,
                              YEAR  => 1990) ;

    FIRST_DATE   : DATE_ACCESS  := NEW DATE'(DAY   => 6,
                                             MONTH => JUN,
                                             YEAR  => 1967) ;
    
    TYPE DUE_DATES IS ARRAY (MONTH_TYPE RANGE JAN .. DEC) OF DATE ;
    REPORT_DATES : DUE_DATES := ((JAN, 23, 1990), (FEB, 23, 1990),
                                 (MAR, 23, 1990), (APR, 23, 1990),
                                 (MAY, 23, 1990), (JUN, 22, 1990),
                                 (JUL, 23, 1990), (AUG, 23, 1990),
                                 (SEP, 24, 1990), (OCT, 23, 1990),
                                 (NOV, 23, 1990), (DEC, 20, 1990)) ;
                                 
    TYPE LIST_INDEX IS RANGE 1 .. 16 ;
    TYPE LIST IS ARRAY (LIST_INDEX) OF NATURAL ;
    ORDER_LIST : LIST := (OTHERS => 0) ;

    GENERIC
    
        TYPE RETURN_TYPE IS PRIVATE ;
        RETURN_VALUE : IN OUT RETURN_TYPE ;
        POSITION      : IN       NATURAL ;
        OFFSET        : IN       NATURAL ;
        WHEN_ELAB     : IN OUT NATURAL ;
        TYPE INDEX IS RANGE <> ;
        TYPE LIST IS ARRAY (INDEX) OF NATURAL ;
        ORDER_LIST      : IN OUT LIST ;
    
    FUNCTION NAME (VALUE : IN NATURAL) RETURN RETURN_TYPE ;
    
    FUNCTION NAME (VALUE : IN NATURAL) RETURN RETURN_TYPE IS
    
    BEGIN -- NAME
        
        IF (VALUE = POSITION) THEN
          WHEN_ELAB := NATURAL'SUCC (WHEN_ELAB) ;
          ORDER_LIST (INDEX (POSITION)) := WHEN_ELAB ;
          RETURN RETURN_VALUE ;
        ELSIF (VALUE = (POSITION + OFFSET)) THEN
          WHEN_ELAB := NATURAL'SUCC (WHEN_ELAB) ;
          ORDER_LIST (INDEX (POSITION + OFFSET)) := WHEN_ELAB ;
          RETURN RETURN_VALUE ;
        END IF ;
    
    END NAME ;
    
    GENERIC
    
        TYPE FIRST_TYPE IS PRIVATE ;
        WITH FUNCTION FIRST (POSITION : IN NATURAL) 
                            RETURN FIRST_TYPE ;
        FIRST_VALUE : IN NATURAL ;
        TYPE SECOND_TYPE IS PRIVATE ;
        WITH FUNCTION SECOND (POSITION : IN NATURAL) 
                            RETURN SECOND_TYPE ;
        SECOND_VALUE : IN NATURAL ;
        TYPE THIRD_TYPE IS PRIVATE ;
        WITH FUNCTION THIRD (POSITION : IN NATURAL) 
                            RETURN THIRD_TYPE ;
        THIRD_VALUE : IN NATURAL ;
        TYPE FOURTH_TYPE IS PRIVATE ;
        WITH FUNCTION FOURTH (POSITION : IN NATURAL) 
                            RETURN FOURTH_TYPE ;
        FOURTH_VALUE : IN NATURAL ;
        TYPE FIFTH_TYPE IS PRIVATE ;
        WITH FUNCTION FIFTH (POSITION : IN NATURAL) 
                            RETURN FIFTH_TYPE ;
        FIFTH_VALUE : IN NATURAL ;
        TYPE SIXTH_TYPE IS PRIVATE ;
        WITH FUNCTION SIXTH (POSITION : IN NATURAL) 
                            RETURN SIXTH_TYPE ;
        SIXTH_VALUE : IN NATURAL ;
        TYPE SEVENTH_TYPE IS PRIVATE ;
        WITH FUNCTION SEVENTH (POSITION : IN NATURAL) 
                            RETURN SEVENTH_TYPE ;
        SEVENTH_VALUE : IN NATURAL ;
        TYPE EIGHTH_TYPE IS PRIVATE ;
        WITH FUNCTION EIGHTH (POSITION : IN NATURAL) 
                            RETURN EIGHTH_TYPE ;
        EIGHTH_VALUE : IN NATURAL ;
        TYPE NINTH_TYPE IS PRIVATE ;
        WITH FUNCTION NINTH (POSITION : IN NATURAL) 
                            RETURN NINTH_TYPE ;
        NINTH_VALUE : IN NATURAL ;
        TYPE TENTH_TYPE IS PRIVATE ;
        WITH FUNCTION TENTH (POSITION : IN NATURAL) 
                            RETURN TENTH_TYPE ;
        TENTH_VALUE : IN NATURAL ;
        TYPE ELEVENTH_TYPE IS PRIVATE ;
        WITH FUNCTION ELEVENTH (POSITION : IN NATURAL) 
                            RETURN ELEVENTH_TYPE ;
        ELEVENTH_VALUE : IN NATURAL ;
        TYPE TWELFTH_TYPE IS PRIVATE ;
        WITH FUNCTION TWELFTH (POSITION : IN NATURAL) 
                            RETURN TWELFTH_TYPE ;
        TWELFTH_VALUE : IN NATURAL ;
        TYPE THIRTEENTH_TYPE IS PRIVATE ;
        WITH FUNCTION THIRTEENTH (POSITION : IN NATURAL) 
                            RETURN THIRTEENTH_TYPE ;
        THIRTEENTH_VALUE : IN NATURAL ;
        TYPE FOURTEENTH_TYPE IS PRIVATE ;
        WITH FUNCTION FOURTEENTH (POSITION : IN NATURAL) 
                            RETURN FOURTEENTH_TYPE ;
        FOURTEENTH_VALUE : IN NATURAL ;
        TYPE FIFTEENTH_TYPE IS PRIVATE ;
        WITH FUNCTION FIFTEENTH (POSITION : IN NATURAL) 
                            RETURN FIFTEENTH_TYPE ;
        FIFTEENTH_VALUE : IN NATURAL ;
        TYPE SIXTEENTH_TYPE IS PRIVATE ;
        WITH FUNCTION SIXTEENTH (POSITION : IN NATURAL) 
                            RETURN SIXTEENTH_TYPE ;
        SIXTEENTH_VALUE : IN NATURAL ;
        
    PACKAGE ORDER_PACKAGE IS
    
        A : FIRST_TYPE      := FIRST (FIRST_VALUE) ;
        B : SECOND_TYPE     := SECOND (SECOND_VALUE) ;
        C : THIRD_TYPE      := THIRD (THIRD_VALUE) ;
        D : FOURTH_TYPE     := FOURTH (FOURTH_VALUE) ;
        E : FIFTH_TYPE      := FIFTH (FIFTH_VALUE) ;
        F : SIXTH_TYPE      := SIXTH (SIXTH_VALUE) ;
        G : SEVENTH_TYPE    := SEVENTH (SEVENTH_VALUE) ;
        H : EIGHTH_TYPE     := EIGHTH (EIGHTH_VALUE) ;
        I : NINTH_TYPE      := NINTH (NINTH_VALUE) ;
        J : TENTH_TYPE      := TENTH (TENTH_VALUE) ;
        K : ELEVENTH_TYPE   := ELEVENTH (ELEVENTH_VALUE) ;
        L : TWELFTH_TYPE    := TWELFTH (TWELFTH_VALUE) ;
        M : THIRTEENTH_TYPE := THIRTEENTH (THIRTEENTH_VALUE) ;
        N : FOURTEENTH_TYPE := FOURTEENTH (FOURTEENTH_VALUE) ;
        O : FIFTEENTH_TYPE  := FIFTEENTH (FIFTEENTH_VALUE) ;
        P : SIXTEENTH_TYPE  := SIXTEENTH (SIXTEENTH_VALUE) ;
        
    END ORDER_PACKAGE ;
    

    FUNCTION BOOL IS NEW NAME (RETURN_TYPE  => BOOLEAN,