Subversion Repositories openrisc

-- 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;