1-- C43215A.ADA
2
3--                             Grant of Unlimited Rights
4--
5--     Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687,
6--     F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained
7--     unlimited rights in the software and documentation contained herein.
8--     Unlimited rights are defined in DFAR 252.227-7013(a)(19).  By making
9--     this public release, the Government intends to confer upon all
10--     recipients unlimited rights  equal to those held by the Government.
11--     These rights include rights to use, duplicate, release or disclose the
12--     released technical data and computer software in whole or in part, in
13--     any manner and for any purpose whatsoever, and to have or permit others
14--     to do so.
15--
16--                                    DISCLAIMER
17--
18--     ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR
19--     DISCLOSED ARE AS IS.  THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED
20--     WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE
21--     SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE
22--     OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A
23--     PARTICULAR PURPOSE OF SAID MATERIAL.
24--*
25-- CHECK THAT CONSTRAINT_ERROR IS RAISED FOR A POSITIONAL
26-- ARRAY AGGREGATE WHOSE UPPER BOUND EXCEEDS THE UPPER BOUND
27-- OF THE INDEX SUBTYPE BUT BELONGS TO THE INDEX BASE TYPE.
28
29-- EG  02/13/84
30
31WITH REPORT;
32WITH SYSTEM;
33
34PROCEDURE C43215A IS
35
36     USE REPORT;
37     USE SYSTEM;
38
39BEGIN
40
41     TEST("C43215A","CHECK THAT CONSTRAINT_ERROR IS RAISED "      &
42                    "FOR A POSITIONAL ARRAY AGGREGATE WHOSE "     &
43                    "UPPER BOUND EXCEEDS THE UPPER BOUND OF THE " &
44                    "INDEX SUBTYPE BUT BELONGS TO THE INDEX "     &
45                    "BASE TYPE");
46
47     BEGIN
48
49CASE_A :  DECLARE
50
51               LOWER_BOUND : CONSTANT  := MAX_INT-3;
52               UPPER_BOUND : CONSTANT  := MAX_INT-1;
53
54               TYPE STA IS RANGE LOWER_BOUND .. UPPER_BOUND;
55
56               TYPE TA IS ARRAY(STA RANGE <>) OF INTEGER;
57
58               A1 : TA(STA);
59               OK : EXCEPTION;
60
61               FUNCTION FUN1 RETURN TA IS
62               BEGIN
63                    RETURN (1, 2, 3, 4);
64               EXCEPTION
65                    WHEN CONSTRAINT_ERROR =>
66                    BEGIN
67                         COMMENT ("CASE A : CONSTRAINT_ERROR RAISED");
68                         RAISE OK;
69                    END;
70                    WHEN OTHERS =>
71                    BEGIN
72                         FAILED ("CASE A : EXCEPTION RAISED IN FUN1");
73                         RAISE OK;
74                    END;
75               END FUN1;
76
77          BEGIN
78
79               A1 := FUN1;
80               FAILED ("CASE A : CONSTRAINT_ERROR NOT RAISED");
81
82          EXCEPTION
83
84               WHEN OK =>
85                    NULL;
86
87               WHEN OTHERS =>
88                    FAILED ("CASE A : EXCEPTION RAISED");
89
90          END CASE_A;
91
92CASE_B :  DECLARE
93
94               TYPE ENUM IS (A, B, C, D);
95
96               SUBTYPE STB IS ENUM RANGE A .. C;
97
98               TYPE TB IS ARRAY(STB RANGE <>) OF INTEGER;
99
100               B1 : TB(STB);
101               OK : EXCEPTION;
102
103               FUNCTION FUN1 RETURN TB IS
104               BEGIN
105                    RETURN (1, 2, 3, 4);
106               EXCEPTION
107                    WHEN CONSTRAINT_ERROR =>
108                    BEGIN
109                         COMMENT ("CASE B : CONSTRAINT_ERROR RAISED");
110                         RAISE OK;
111                    END;
112                    WHEN OTHERS =>
113                    BEGIN
114                         FAILED ("CASE B : EXCEPTION RAISED IN FUN1");
115                         RAISE OK;
116                    END;
117               END FUN1;
118
119          BEGIN
120
121               B1 := FUN1;
122               FAILED ("CASE B : CONSTRAINT_ERROR NOT RAISED");
123
124          EXCEPTION
125
126               WHEN OK =>
127                    NULL;
128
129               WHEN OTHERS =>
130                    FAILED ("CASE B : EXCEPTION RAISED");
131
132          END CASE_B;
133
134     END;
135
136     RESULT;
137
138END C43215A;
139