c95085c.ada

来自「linux下编程用 编译软件」· ADA 代码 · 共 246 行

-- C95085C.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 RAISED UNDER THE
-- APPROPRIATE CIRCUMSTANCES FOR ARRAY PARAMETERS IN ENTRY CALLS,
-- NAMELY WHEN THE ACTUAL BOUNDS DON'T MATCH THE FORMAL BOUNDS
-- (BEFORE THE CALL FOR ALL MODES).
-- SUBTESTS ARE:
--      (A) IN MODE, ONE DIMENSION, STATIC AGGREGATE.
--      (B) IN MODE, TWO DIMENSIONS, DYNAMIC AGGREGATE.
--      (C) IN MODE, TWO DIMENSIONS, DYNAMIC VARIABLE.
--      (D) IN OUT MODE, THREE DIMENSIONS, STATIC VARIABLE.
--      (E) OUT MODE, ONE DIMENSION, DYNAMIC VARIABLE.
--      (F) IN OUT MODE, NULL STRING AGGREGATE.
--      (G) IN OUT MODE, TWO DIMENSIONS, NULL AGGREGATE (OK CASE).
--          IN OUT MODE, TWO DIMENSIONS, NULL AGGREGATE.

-- JWC 10/28/85
-- PWN 11/30/94 REMOVED TEST ILLEGAL IN ADA 9X.

WITH REPORT; USE REPORT;
PROCEDURE C95085C IS

BEGIN
     TEST ("C95085C", "CHECK THAT CONSTRAINT_ERROR IS RAISED WHEN " &
                      "ACTUAL ARRAY BOUNDS DON'T MATCH FORMAL BOUNDS");

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

     DECLARE -- (A)
          SUBTYPE ST IS STRING (1..3);

          TASK TSK IS
               ENTRY E (A : ST);
          END TSK;

          TASK BODY TSK IS
          BEGIN
               SELECT
                    ACCEPT E (A : ST) DO
                         FAILED ("EXCEPTION NOT RAISED ON CALL - (A)");
                    END E;
               OR
                    TERMINATE;
               END SELECT;
          EXCEPTION
               WHEN OTHERS =>
                    FAILED ("EXCEPTION RAISED IN TASK - (A)");
          END TSK;

     BEGIN -- (A)

          TSK.E ("AB");
          FAILED ("EXCEPTION NOT RAISED BEFORE CALL - (A)");

     EXCEPTION
          WHEN CONSTRAINT_ERROR =>
               NULL;
          WHEN OTHERS =>
               FAILED ("WRONG EXCEPTION RAISED - (A)");
     END; -- (A)

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

     DECLARE -- (B)

          SUBTYPE S IS INTEGER RANGE 1..3;
          TYPE T IS ARRAY (S,S) OF INTEGER;

          TASK TSK IS
               ENTRY E (A : T);
          END TSK;

          TASK BODY TSK IS
          BEGIN
               SELECT
                    ACCEPT E (A : T) DO
                         FAILED ("EXCEPTION NOT RAISED ON CALL - (B)");
                    END E;
               OR
                    TERMINATE;
               END SELECT;
          EXCEPTION
               WHEN OTHERS =>
                    FAILED ("EXCEPTION RAISED IN TASK - (B)");
          END TSK;

     BEGIN -- (B)

          TSK.E ((1..3 => (1..IDENT_INT(2) => 0)));
          FAILED ("EXCEPTION NOT RAISED BEFORE CALL - (B)");

     EXCEPTION
          WHEN CONSTRAINT_ERROR =>
               NULL;
          WHEN OTHERS =>
               FAILED ("WRONG EXCEPTION RAISED - (B)");
     END; -- (B)

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

     DECLARE -- (C)

          SUBTYPE S IS INTEGER RANGE 1..5;
          TYPE T IS ARRAY (S RANGE <>, S RANGE <>) OF INTEGER;
          SUBTYPE ST IS T (1..3,1..3);
          V : T (1..IDENT_INT(2), 1..3) :=
                (1..IDENT_INT(2) => (1..3 => 0));

          TASK TSK IS
               ENTRY E (A :ST);
          END TSK;

          TASK BODY TSK IS
          BEGIN
               SELECT
                    ACCEPT E (A :ST) DO
                         FAILED ("EXCEPTION NOT RAISED ON CALL - (C)");
                    END E;
               OR
                    TERMINATE;
               END SELECT;
          EXCEPTION
               WHEN OTHERS =>
                    FAILED ("EXCEPTION RAISED IN TASK - (C)");
          END TSK;

     BEGIN -- (C)

          TSK.E (V);
          FAILED ("EXCEPTION NOT RAISED BEFORE CALL - (C)");

     EXCEPTION
          WHEN CONSTRAINT_ERROR =>
               NULL;
          WHEN OTHERS =>
               FAILED ("WRONG EXCEPTION RAISED - (C)");
     END; -- (C)

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

     DECLARE -- (D)

          SUBTYPE S IS INTEGER RANGE 1..5;
          TYPE T IS ARRAY (S RANGE <>, S RANGE <>, S RANGE <>) OF
                    INTEGER;
          SUBTYPE ST IS T (1..3, 1..3, 1..3);
          V : T (1..3, 1..2, 1..3) :=
                (1..3 => (1..2 => (1..3 => 0)));

          TASK TSK IS
               ENTRY E (A : IN OUT ST);
          END TSK;

          TASK BODY TSK IS
          BEGIN
               SELECT
                    ACCEPT E (A : IN OUT ST) DO
                         FAILED ("EXCEPTION NOT RAISED ON CALL - (D)");
                    END E;
               OR
                    TERMINATE;
               END SELECT;
          EXCEPTION
               WHEN OTHERS =>
                    FAILED ("EXCEPTION RAISED IN TASK - (D)");
          END TSK;

     BEGIN -- (D)

          TSK.E (V);
          FAILED ("EXCEPTION NOT RAISED BEFORE CALL - (D)");

     EXCEPTION
          WHEN CONSTRAINT_ERROR =>
               NULL;
          WHEN OTHERS =>
               FAILED ("WRONG EXCEPTION RAISED - (D)");
     END; -- (D)

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


     DECLARE -- (G)

          SUBTYPE S IS INTEGER RANGE 1..5;
          TYPE T IS ARRAY (S RANGE <>, S RANGE <>) OF CHARACTER;
          SUBTYPE ST IS T (2..1, 2..1);
          V : T (2..1, 2..1) := (2..1 => (2..1 => ' '));

          TASK TSK IS
               ENTRY E (A : IN OUT ST);
          END TSK;

          TASK BODY TSK IS
          BEGIN
               SELECT
                    ACCEPT E (A : IN OUT ST)  DO
                         COMMENT ("OK CASE CALLED CORRECTLY");
                    END E;
               OR
                    TERMINATE;
               END SELECT;
          EXCEPTION
               WHEN OTHERS =>
                    FAILED ("EXCEPTION RAISED IN TASK - (G)");
          END TSK;

     BEGIN -- (G)

          TSK.E (V);

     EXCEPTION
          WHEN CONSTRAINT_ERROR =>
               FAILED ("CONSTRAINT_ERROR RAISED ON OK CASE - (G)");
          WHEN OTHERS =>
               FAILED ("OTHER EXCEPTION RAISED ON OK CASE - (G)");
     END; -- (G)

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


     RESULT;
END C95085C;