c95086e.ada

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

-- C95086E.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 CONSTRAINT_ERROR IS NOT RAISED BEFORE OR AFTER THE ENTRY
-- CALL FOR IN OUT ARRAY PARAMETERS, WHERE THE ACTUAL PARAMETER HAS THE
-- FORM OF A TYPE CONVERSION.  THE FOLLOWING CASES ARE TESTED:
--   (A) OK CASE.
--   (B) FORMAL CONSTRAINED, BOTH FORMAL AND ACTUAL HAVE SAME NUMBER
--       COMPONENTS PER DIMENSION, BUT ACTUAL INDEX BOUNDS LIE OUTSIDE
--       FORMAL INDEX SUBTYPE.
--   (C) FORMAL CONSTRAINED, FORMAL AND ACTUAL HAVE DIFFERENT NUMBER
--       COMPONENTS PER DIMENSION, BOTH FORMAL AND ACTUAL ARE NULL
--       ARRAYS.
--   (D) FORMAL CONSTRAINED, ACTUAL NULL, WITH INDEX BOUNDS OUTSIDE
--       FORMAL INDEX SUBTYPE.
--   (E) FORMAL UNCONSTRAINED, ACTUAL NULL, WITH INDEX BOUNDS OUTSIDE
--       FORMAL INDEX SUBTYPE FOR NULL DIMENSIONS ONLY.

-- RJW 2/3/86
-- TMB 11/15/95 ELIMINATED INCOMPATIBILITY WITH ADA95
-- TMB 11/19/96 FIXED SLIDING PROBLEM IN SECTION D

WITH REPORT; USE REPORT;
PROCEDURE C95086E IS

BEGIN
     TEST ("C95086E", "CHECK THAT CONSTRAINT_ERROR IS NOT RAISED " &
           "BEFORE OR AFTER THE ENTRY CALL FOR IN OUT ARRAY " &
           "PARAMETERS, WITH THE ACTUAL HAVING THE FORM OF A TYPE " &
           "CONVERSION");

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

     DECLARE -- (A)

          SUBTYPE INDEX IS INTEGER RANGE 1..5;
          TYPE ARRAY_TYPE IS ARRAY (INDEX RANGE <>, INDEX RANGE <>)
               OF BOOLEAN;
          SUBTYPE FORMAL IS ARRAY_TYPE (1..3, 1..3);
          SUBTYPE ACTUAL IS ARRAY_TYPE (1..3, 1..3);
          AR : ACTUAL := (1..3 => (1..3 => TRUE));
          CALLED : BOOLEAN := FALSE;

          TASK T IS
               ENTRY E (X : IN OUT FORMAL);
          END T;

          TASK BODY T IS
          BEGIN
               ACCEPT E (X : IN OUT FORMAL) DO
                    CALLED := TRUE;
               END E;
          EXCEPTION
               WHEN OTHERS =>
                    FAILED ("EXCEPTION RAISED IN TASK - (A)");
          END T;

     BEGIN -- (A)

          T.E (FORMAL (AR));

     EXCEPTION
          WHEN CONSTRAINT_ERROR =>
               IF NOT CALLED THEN
                    FAILED ("EXCEPTION RAISED BEFORE CALL - (A)");
               ELSE
                    FAILED ("EXCEPTION RAISED ON RETURN - (A)");
               END IF;
          WHEN OTHERS =>
               FAILED ("EXCEPTION RAISED - (A)");
     END; -- (A)

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

     DECLARE -- (B)

          SUBTYPE INDEX IS INTEGER RANGE 1..3;
          TYPE FORMAL IS ARRAY (INDEX, INDEX) OF BOOLEAN;
          TYPE ACTUAL IS ARRAY (3..5, 3..5) OF BOOLEAN;
          AR : ACTUAL := (3..5 => (3..5 => FALSE));
          CALLED : BOOLEAN := FALSE;

          TASK T IS
               ENTRY E (X : IN OUT FORMAL);
          END T;

          TASK BODY T IS
          BEGIN
               ACCEPT E (X : IN OUT FORMAL) DO
                    CALLED := TRUE;
                    X(3, 3) := TRUE;
               END E;
          EXCEPTION
               WHEN OTHERS =>
                    FAILED ("EXCEPTION RAISED IN TASK - (B)");
          END T;

     BEGIN -- (B)

          T.E (FORMAL (AR));
          IF AR(5, 5) /= TRUE THEN
               FAILED ("INCORRECT RETURNED VALUE - (B)");
          END IF;

     EXCEPTION
          WHEN CONSTRAINT_ERROR =>
               IF NOT CALLED THEN
                    FAILED ("EXCEPTION RAISED BEFORE CALL - (B)");
               ELSE
                    FAILED ("EXCEPTION RAISED ON RETURN - (B)");
               END IF;
          WHEN OTHERS =>
               FAILED ("EXCEPTION RAISED - (B)");
     END; -- (B)

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

     DECLARE -- (C)

          SUBTYPE INDEX IS INTEGER RANGE 1..5;
          TYPE ARRAY_TYPE IS ARRAY (INDEX RANGE <>, INDEX RANGE <>)
               OF CHARACTER;
          SUBTYPE FORMAL IS ARRAY_TYPE (2..0, 1..3);
          AR : ARRAY_TYPE (2..1, 1..3) := (2..1 => (1..3 => ' '));
          CALLED : BOOLEAN := FALSE;

          TASK T IS
               ENTRY E (X : IN OUT FORMAL);
          END T;

          TASK BODY T IS
          BEGIN
               ACCEPT E (X : IN OUT FORMAL) DO
                    IF X'LAST /= 0 AND X'LAST(2) /= 3 THEN
                         FAILED ("WRONG BOUNDS PASSED - (C)");
                    END IF;
                    CALLED := TRUE;
                    X := (2..0 => (1..3 => 'A'));
               END E;
          EXCEPTION
               WHEN OTHERS =>
                    FAILED ("EXCEPTION RAISED IN TASK - (C)");
          END T;

     BEGIN -- (C)

          T.E (FORMAL (AR));
          IF AR'LAST /= 1 AND AR'LAST(2) /= 3 THEN
               FAILED ("BOUNDS CHANGED - (C)");
          END IF;

     EXCEPTION
          WHEN CONSTRAINT_ERROR =>
               IF NOT CALLED THEN
                    FAILED ("EXCEPTION RAISED BEFORE CALL - (C)");
               ELSE
                    FAILED ("EXCEPTION RAISED ON RETURN - (C)");
               END IF;
          WHEN OTHERS =>
               FAILED ("EXCEPTION RAISED - (C)");
     END; -- (C)

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

     DECLARE -- (D)

          SUBTYPE INDEX IS INTEGER RANGE 1..3;
          TYPE FORMAL IS ARRAY (INDEX RANGE 1..3, INDEX RANGE 3..1)
               OF CHARACTER;
          TYPE ACTUAL IS ARRAY (3..5, 5..3) OF CHARACTER;
          AR : ACTUAL := (3..5 => (5..3 => ' '));
          CALLED : BOOLEAN := FALSE;

          TASK T IS
               ENTRY E (X : IN OUT FORMAL);
          END T;

          TASK BODY T IS
          BEGIN
               ACCEPT E (X : IN OUT FORMAL) DO
                    IF X'LAST /= 3 AND X'LAST(2) /= 1 THEN
                         FAILED ("WRONG BOUNDS PASSED - (D)");
                    END IF;
                    CALLED := TRUE;
                    X := (1..3 => (3..1 => 'A'));
               END E;
          EXCEPTION
               WHEN OTHERS =>
                    FAILED ("EXCEPTION RAISED IN TASK - (D)");
          END T;

     BEGIN -- (D)

          T.E (FORMAL (AR));
          IF AR'LAST /= 5 AND AR'LAST(2) /= 3 THEN
               FAILED ("BOUNDS CHANGED - (D)");
          END IF;

     EXCEPTION
          WHEN CONSTRAINT_ERROR =>
               IF NOT CALLED THEN
                    FAILED ("EXCEPTION RAISED BEFORE CALL - (D)");
               ELSE
                    FAILED ("EXCEPTION RAISED ON RETURN - (D)");
               END IF;
          WHEN OTHERS =>
               FAILED ("EXCEPTION RAISED - (D)");
     END; -- (D)

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

     DECLARE -- (E)

          SUBTYPE INDEX IS INTEGER RANGE 1..3;
          TYPE FORMAL IS ARRAY (INDEX RANGE <>, INDEX RANGE <>)
               OF CHARACTER;
          TYPE ACTUAL IS ARRAY (POSITIVE RANGE 5..2,
                                POSITIVE RANGE 1..3) OF CHARACTER;
          AR : ACTUAL := (5..2 => (1..3 => ' '));
          CALLED : BOOLEAN := FALSE;

          TASK T IS
               ENTRY E (X : IN OUT FORMAL);
          END T;

          TASK BODY T IS
          BEGIN
               ACCEPT E (X : IN OUT FORMAL) DO
                    IF X'LAST /= 2 AND X'LAST(2) /= 3 THEN
                         FAILED ("WRONG BOUNDS PASSED - (E)");
                    END IF;
                    CALLED := TRUE;
                    X := (3..1 => (1..3 => ' '));
               END E;
          EXCEPTION
               WHEN OTHERS =>
                    FAILED ("EXCEPTION RAISED IN TASK - (E)");
          END T;

     BEGIN -- (E)

          T.E (FORMAL (AR));
          IF AR'LAST /= 2 AND AR'LAST(2) /= 3 THEN
               FAILED ("BOUNDS CHANGED - (E)");
          END IF;

     EXCEPTION
          WHEN CONSTRAINT_ERROR =>
               IF NOT CALLED THEN
                    FAILED ("EXCEPTION RAISED BEFORE CALL - (E)");
               ELSE
                    FAILED ("EXCEPTION RAISED ON RETURN - (E)");
               END IF;
          WHEN OTHERS =>
               FAILED ("EXCEPTION RAISED - (E)");
     END; -- (E)

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

     RESULT;
END C95086E;