cc3017b.ada

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

                  UPPER => 80);
     EXCEPTION
          WHEN OTHERS =>
               REPORT.FAILED ("EXCEPTION RAISED IN CALL TO NEW_PC");
     END REC_NON_STAT_COMPS ;

     --------------------------------------------------

     FIRST_STATIC_ARRAY:

     DECLARE
     
--        (D) AN ARRAY PARAMETER CONSTRAINED WITH STATIC BOUNDS ON SUB-
--            SCRIPTS AND NON-STATIC BOUNDS ON COMPONENTS, INITIALIZED
--            WITH A STATIC AGGREGATE.

          TYPE NUMBER IS RANGE 1 .. 100 ;
          
          GENERIC
          
            TYPE INTEGER_TYPE IS RANGE <> ;
            F_STATIC_VALUE : IN INTEGER_TYPE ;
            S_STATIC_VALUE : IN INTEGER_TYPE ;
            T_STATIC_VALUE : IN INTEGER_TYPE ;
            L_STATIC_VALUE : IN INTEGER_TYPE ;
            A_STATIC_VALUE : IN INTEGER_TYPE ;
            B_STATIC_VALUE : IN INTEGER_TYPE ;
            C_STATIC_VALUE : IN INTEGER_TYPE ;
            D_STATIC_VALUE : IN INTEGER_TYPE ;
          
          PROCEDURE P1D (LOWER  : IN INTEGER_TYPE ;
                         UPPER  : IN INTEGER_TYPE) ;

          PROCEDURE P1D (LOWER  : IN INTEGER_TYPE ;
                         UPPER  : IN INTEGER_TYPE) IS
                         
               SUBTYPE SUBINTEGER_TYPE IS INTEGER_TYPE
                       RANGE LOWER .. UPPER ;

               TYPE A1 IS ARRAY (INTEGER_TYPE RANGE
                                       F_STATIC_VALUE .. S_STATIC_VALUE,
                                 INTEGER_TYPE RANGE
                                       T_STATIC_VALUE .. L_STATIC_VALUE)
                       OF SUBINTEGER_TYPE ;

               PROCEDURE P1D1 (A : A1 :=
                           ((A_STATIC_VALUE, B_STATIC_VALUE),
                           (C_STATIC_VALUE, D_STATIC_VALUE))) IS
               BEGIN  -- P1D1
                    REPORT.FAILED ("BODY OF P1D1 EXECUTED");
               EXCEPTION
                    WHEN OTHERS =>
                         REPORT.FAILED ("EXCEPTION RAISED IN P1D1");
               END P1D1;

          BEGIN  -- P1D
               P1D1 ;
          EXCEPTION
               WHEN CONSTRAINT_ERROR =>
                    NULL;
               WHEN OTHERS =>
                    REPORT.FAILED ("WRONG EXCEPTION RAISED - P1D1");
          END P1D;
          
          PROCEDURE NEW_P1D IS NEW P1D (INTEGER_TYPE => NUMBER,
                                        F_STATIC_VALUE => 21,
                                        S_STATIC_VALUE => 37,
                                        T_STATIC_VALUE => 67,
                                        L_STATIC_VALUE => 79,
                                        A_STATIC_VALUE => 11,
                                        B_STATIC_VALUE => 88,
                                        C_STATIC_VALUE => 87,
                                        D_STATIC_VALUE => 13) ;

     BEGIN  -- FIRST_STATIC_ARRAY
          NEW_P1D (LOWER => 10,
                     UPPER => 90);
     EXCEPTION
          WHEN OTHERS =>
               REPORT.FAILED ("EXCEPTION RAISED IN CALL TO NEW_P1D");
     END FIRST_STATIC_ARRAY ;

     --------------------------------------------------

     SECOND_STATIC_ARRAY:
     
     DECLARE
     
--        (D) AN ARRAY PARAMETER CONSTRAINED WITH STATIC BOUNDS ON SUB-
--            SCRIPTS AND NON-STATIC BOUNDS ON COMPONENTS, INITIALIZED
--            WITH A STATIC AGGREGATE.

          TYPE NUMBER IS RANGE 1 .. 100 ;
          
          GENERIC
          
            TYPE INTEGER_TYPE IS RANGE <> ;
            F_STATIC_VALUE : IN INTEGER_TYPE ;
            S_STATIC_VALUE : IN INTEGER_TYPE ;
            T_STATIC_VALUE : IN INTEGER_TYPE ;
            L_STATIC_VALUE : IN INTEGER_TYPE ;
            A_STATIC_VALUE : IN INTEGER_TYPE ;
            B_STATIC_VALUE : IN INTEGER_TYPE ;
          
          PROCEDURE P2D (LOWER  : IN INTEGER_TYPE ;
                         UPPER  : IN INTEGER_TYPE) ;

          PROCEDURE P2D (LOWER  : IN INTEGER_TYPE ;
                         UPPER  : IN INTEGER_TYPE) IS
                         
               SUBTYPE SUBINTEGER_TYPE IS INTEGER_TYPE
                       RANGE LOWER .. UPPER ;

               TYPE A1 IS ARRAY (INTEGER_TYPE RANGE
                                       F_STATIC_VALUE .. S_STATIC_VALUE,
                                 INTEGER_TYPE RANGE
                                       T_STATIC_VALUE .. L_STATIC_VALUE)
                       OF SUBINTEGER_TYPE ;

               PROCEDURE P2D1 (A : A1 :=
                                   (F_STATIC_VALUE .. S_STATIC_VALUE =>
                                   (A_STATIC_VALUE, B_STATIC_VALUE))) IS
               BEGIN  -- P2D1
                    REPORT.FAILED ("BODY OF P2D1 EXECUTED");
               EXCEPTION
                    WHEN OTHERS =>
                         REPORT.FAILED ("EXCEPTION RAISED IN P2D1");
               END P2D1;

          BEGIN  -- P2D
               P2D1;
          EXCEPTION
               WHEN CONSTRAINT_ERROR =>
                    NULL;
               WHEN OTHERS =>
                    REPORT.FAILED ("WRONG EXCEPTION RAISED - P2D1");
          END P2D;
          
          PROCEDURE NEW_P2D IS NEW P2D (INTEGER_TYPE => NUMBER,
                                        F_STATIC_VALUE => 21,
                                        S_STATIC_VALUE => 37,
                                        T_STATIC_VALUE => 67,
                                        L_STATIC_VALUE => 79,
                                        A_STATIC_VALUE => 7,
                                        B_STATIC_VALUE => 93) ;

     BEGIN  -- SECOND_STATIC_ARRAY
          NEW_P2D (LOWER => 5,
                   UPPER => 95);
     EXCEPTION
          WHEN OTHERS =>
               REPORT.FAILED ("EXCEPTION RAISED IN CALL TO NEW_P2D");
     END SECOND_STATIC_ARRAY ;

     --------------------------------------------------

     REC_NON_STATIC_CONS:
     
     DECLARE
     
--        (E) A RECORD PARAMETER WITH A NON-STATIC CONSTRAINT
--            INITIALIZED WITH A STATIC AGGREGATE.

          TYPE NUMBER IS RANGE 1 .. 100 ;
          
          GENERIC
          
            TYPE INTEGER_TYPE IS RANGE <> ;
            F_STATIC_VALUE : IN INTEGER_TYPE ;
            S_STATIC_VALUE : IN INTEGER_TYPE ;
            T_STATIC_VALUE : IN INTEGER_TYPE ;
            L_STATIC_VALUE : IN INTEGER_TYPE ;
            D_STATIC_VALUE : IN INTEGER_TYPE ;
          
          PROCEDURE PE (LOWER  : IN INTEGER_TYPE ;
                        UPPER  : IN INTEGER_TYPE) ;

          PROCEDURE PE (LOWER  : IN INTEGER_TYPE ;
                        UPPER  : IN INTEGER_TYPE) IS
                        
               SUBTYPE SUBINTEGER_TYPE IS INTEGER_TYPE
                       RANGE LOWER .. UPPER ;
               TYPE AR1 IS ARRAY (INTEGER RANGE 1..3) OF 
                     SUBINTEGER_TYPE ;
                    
               TYPE REC (DISCRIM : SUBINTEGER_TYPE) IS
                    RECORD
                         FIRST  : SUBINTEGER_TYPE ;
                         SECOND : AR1 ;
                    END RECORD ;

               SUBTYPE REC4 IS REC (LOWER) ;

               PROCEDURE PE1 (R : REC4 := (D_STATIC_VALUE,
                                           F_STATIC_VALUE,
                                          (S_STATIC_VALUE,
                                           T_STATIC_VALUE,
                                           L_STATIC_VALUE))) IS
               BEGIN  -- PE1
                    REPORT.FAILED ("BODY OF PE1 EXECUTED");
               EXCEPTION
                    WHEN OTHERS =>
                         REPORT.FAILED ("EXCEPTION RAISED IN PE1");
               END PE1;

          BEGIN  -- PE
               PE1;
          EXCEPTION
               WHEN CONSTRAINT_ERROR =>
                    NULL;
               WHEN OTHERS =>
                    REPORT.FAILED ("WRONG EXCEPTION RAISED - PE1");
          END PE;

          PROCEDURE NEW_PE IS NEW PE (INTEGER_TYPE => NUMBER,
                                      F_STATIC_VALUE => 37,
                                      S_STATIC_VALUE => 21,
                                      T_STATIC_VALUE => 67,
                                      L_STATIC_VALUE => 79,
                                      D_STATIC_VALUE => 44) ;

     BEGIN  -- REC_NON_STATIC_CONS
          NEW_PE  (LOWER => 2,
                   UPPER => 99);
     EXCEPTION
          WHEN OTHERS =>
               REPORT.FAILED ("EXCEPTION RAISED IN CALL TO NEW_PE");
     END REC_NON_STATIC_CONS ;

     --------------------------------------------------

     REPORT.RESULT;

END CC3017B;