c64103d.ada

用于进行gcc测试

-- C64103D.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 THE APPROPRIATE EXCEPTION IS RAISED FOR TYPE CONVERSIONS
-- ON OUT ARRAY PARAMETERS.  IN PARTICULAR:
--   (A) CONSTRAINT_ERROR IS RAISED BEFORE THE CALL WHEN THE ACTUAL
--       COMPONENT'S CONSTRAINTS DIFFER FROM THE FORMAL COMPONENT'S
--       CONSTRAINTS.
--   (B) CONSTRAINT_ERROR IS RAISED BEFORE THE CALL WHEN CONVERSION TO
--       AN UNCONSTRAINED ARRAY TYPE CAUSES AN ACTUAL INDEX BOUND TO LIE
--       OUTSIDE OF A FORMAL INDEX SUBTYPE.
--   (C) CONSTRAINT_ERROR IS RAISED BEFORE THE CALL FOR CONVERSION TO A
--       CONSTRAINED ARRAY TYPE WHEN THE NUMBER OF COMPONENTS PER
--       DIMENSION OF THE ACTUAL DIFFERS FROM THAT OF THE FORMAL.
--   (D) CONSTRAINT_ERROR IS RAISED BEFORE THE CALL WHEN CONVERSION TO AN
--       UNCONSTRAINED ARRAY TYPE CAUSES AN ACTUAL INDEX BOUND TO LIE
--       OUTSIDE OF THE BASE INDEX TYPE OF THE FORMAL.

-- *** NOTE: This test has been modified since ACVC version 1.11 to    -- 9X
-- ***       remove incompatibilities associated with the transition   -- 9X
-- ***       to Ada 9X.                                                -- 9X
-- ***                                                                 -- 9X

-- CPP 07/19/84
-- EG  10/29/85  FIX NUMERIC_ERROR/CONSTRAINT_ERROR ACCORDING TO
--               AI-00387.
-- MRM 03/30/93  REMOVED NUMERIC_ERROR FOR 9X COMPATIBILITY
-- PWN 01/31/95  REMOVED INCONSISTENCIES WITH ADA 9X.

WITH SYSTEM;
WITH REPORT;  USE REPORT;
PROCEDURE C64103D IS

     BEGIN
     TEST ("C64103D", "CHECK THAT APPROPRIATE EXCEPTION IS RAISED ON " &
           "TYPE CONVERSIONS OF OUT ARRAY PARAMETERS");

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

     DECLARE   -- (A)
     BEGIN     -- (A)

          DECLARE
               TYPE SUBINT IS RANGE 0..8;
               TYPE ARRAY_TYPE IS ARRAY (SUBINT RANGE <>) OF BOOLEAN;
               A0 : ARRAY_TYPE (0..3) := (0..3 => TRUE);

               PROCEDURE P2 (X : OUT ARRAY_TYPE) IS
               BEGIN
                    NULL;
               END P2;
          BEGIN
               P2 (ARRAY_TYPE (A0));                  -- OK.
          EXCEPTION
               WHEN OTHERS =>
                    FAILED ("EXCEPTION RAISED -P2 (A)");
          END;

     END; -- (A)

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

     DECLARE   -- (B)

          TYPE SUBINT IS RANGE 0..8;
          TYPE ARRAY_TYPE IS ARRAY (SUBINT RANGE <>) OF BOOLEAN;
          TYPE AR1 IS ARRAY (INTEGER RANGE <>) OF BOOLEAN;
          A1 : AR1 (-1..7) := (-1..7 => TRUE);
          A2 : AR1 (1..9) := (1..9 => TRUE);

          PROCEDURE P1 (X : OUT ARRAY_TYPE) IS
          BEGIN
               FAILED ("EXCEPTION NOT RAISED BEFORE CALL -P1 (B)");
          END P1;

     BEGIN     -- (B)

          BEGIN
               COMMENT ("CALL TO P1 (B) ON A1");
               P1 (ARRAY_TYPE (A1));
          EXCEPTION
               WHEN CONSTRAINT_ERROR =>
                    NULL;
               WHEN OTHERS =>
                    FAILED ("WRONG EXCEPTION RAISED -P1 (B)");
          END;

          BEGIN
               COMMENT ("CALL TO P1 (B) ON A2");
               P1 (ARRAY_TYPE (A2));
          EXCEPTION
               WHEN CONSTRAINT_ERROR =>
                    NULL;
               WHEN OTHERS =>
                    FAILED ("WRONG EXCEPTION RAISED -P1 (B)");
          END;

     END; -- (B)

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

     DECLARE   -- (C)
     BEGIN     -- (C)

          DECLARE
               TYPE INDEX1 IS RANGE 1..3;
               TYPE INDEX2 IS RANGE 1..4;
               TYPE AR_TYPE IS ARRAY (INDEX1, INDEX2) OF BOOLEAN;
               A0 : AR_TYPE := (1..3 => (1..4 => FALSE));

               TYPE I1 IS RANGE 1..4;
               TYPE I2 IS RANGE 1..3;
               TYPE ARRAY_TYPE IS ARRAY (I1, I2) OF BOOLEAN;

               PROCEDURE P1 (X : OUT ARRAY_TYPE) IS
               BEGIN
                    FAILED ("EXCEPTION NOT RAISED BEFORE CALL -P1 (C)");
               END P1;
          BEGIN
               P1 (ARRAY_TYPE (A0));
          EXCEPTION
               WHEN CONSTRAINT_ERROR =>
                    NULL;
               WHEN OTHERS =>
                    FAILED ("WRONG EXCEPTION RAISED -P1 (C)");
          END;

     END; -- (C)

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

     DECLARE   -- (D)
     BEGIN     -- (D)

          DECLARE
               TYPE SM_INT IS RANGE 0..2;
               TYPE LG_INT IS RANGE SYSTEM.MIN_INT..SYSTEM.MAX_INT;
               TYPE AR_SMALL IS ARRAY (SM_INT RANGE <>) OF BOOLEAN;
               TYPE AR_LARGE IS ARRAY (LG_INT RANGE <>) OF BOOLEAN;
               A0 : AR_LARGE (SYSTEM.MAX_INT - 2..SYSTEM.MAX_INT) :=
                    (SYSTEM.MAX_INT - 2..SYSTEM.MAX_INT => TRUE);

               PROCEDURE P1 (X : OUT AR_SMALL) IS
               BEGIN
                    FAILED ("EXCEPTION NOT RAISED BEFORE CALL -P1 (D)");
               END P1;
          BEGIN
               IF LG_INT (SM_INT'BASE'LAST) < LG_INT'BASE'LAST THEN
                    P1 (AR_SMALL (A0));
               ELSE
                    COMMENT ("NOT APPLICABLE -P1 (D)");
               END IF;
          EXCEPTION
               WHEN CONSTRAINT_ERROR =>
                    COMMENT ("CONSTRAINT_ERROR RAISED - P1 (D)");
               WHEN OTHERS =>
                    FAILED ("WRONG EXCEPTION RAISED - P1 (D)");
          END;

     END; -- (D)

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

     RESULT;

END C64103D;