1-- C46044B.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 CONVERSION TO A
26-- CONSTRAINED ARRAY TYPE IF THE TARGET TYPE IS NON-NULL AND
27-- CORRESPONDING DIMENSIONS OF THE TARGET AND OPERAND DO NOT HAVE
28-- THE SAME LENGTH. ALSO, CHECK THAT CONSTRAINT_ERROR IS RAISED IF
29-- THE TARGET TYPE IS NULL AND THE OPERAND TYPE IS NON-NULL.
30
31-- R.WILLIAMS 9/8/86
32
33WITH REPORT; USE REPORT;
34PROCEDURE C46044B IS
35
36     TYPE ARR1 IS ARRAY (INTEGER RANGE <>) OF INTEGER;
37
38     SUBTYPE CARR1A IS ARR1 (IDENT_INT (1) .. IDENT_INT (6));
39     C1A : CARR1A := (CARR1A'RANGE => 0);
40
41     SUBTYPE CARR1B IS ARR1 (IDENT_INT (2) .. IDENT_INT (5));
42     C1B : CARR1B := (CARR1B'RANGE => 0);
43
44     SUBTYPE CARR1N IS ARR1 (IDENT_INT (1) .. IDENT_INT (0));
45     C1N : CARR1N := (CARR1N'RANGE => 0);
46
47     TYPE ARR2 IS ARRAY (INTEGER RANGE <>, INTEGER RANGE <>) OF
48          INTEGER;
49
50     SUBTYPE CARR2A IS ARR2 (IDENT_INT (1) .. IDENT_INT (2),
51                             IDENT_INT (1) .. IDENT_INT (2));
52     C2A : CARR2A := (CARR2A'RANGE (1) => (CARR2A'RANGE (2) => 0));
53
54     SUBTYPE CARR2B IS ARR2 (IDENT_INT (0) .. IDENT_INT (2),
55                             IDENT_INT (0) .. IDENT_INT (2));
56     C2B : CARR2B := (CARR2B'RANGE (1) => (CARR2B'RANGE (2) => 0));
57
58     SUBTYPE CARR2N IS ARR2 (IDENT_INT (2) .. IDENT_INT (1),
59                             IDENT_INT (1) .. IDENT_INT (2));
60     C2N : CARR2N := (CARR2N'RANGE (1) => (CARR2N'RANGE (2) => 0));
61
62     PROCEDURE CHECK1 (A : ARR1; STR : STRING) IS
63     BEGIN
64          FAILED ( "NO EXCEPTION RAISED - " & STR );
65     END CHECK1;
66
67     PROCEDURE CHECK2 (A : ARR2; STR : STRING) IS
68     BEGIN
69          FAILED ( "NO EXCEPTION RAISED - " & STR );
70     END CHECK2;
71
72BEGIN
73     TEST ( "C46044B", "CHECK THAT CONSTRAINT ERROR IS RAISED FOR " &
74                       "CONVERSION TO A CONSTRAINED ARRAY TYPE " &
75                       "IF THE TARGET TYPE IS NON-NULL AND " &
76                       "CORRESPONDING DIMENSIONS OF THE TARGET AND " &
77                       "OPERAND DO NOT HAVE THE SAME LENGTH. " &
78                       "ALSO, CHECK THAT CONSTRAINT_ERROR IS " &
79                       "RAISED IF THE TARGET TYPE IS NULL AND " &
80                       "THE OPERAND TYPE IS NON-NULL" );
81
82     BEGIN -- (A).
83          C1A := C1B;
84          CHECK1 (C1A, "(A)");
85     EXCEPTION
86          WHEN CONSTRAINT_ERROR =>
87               NULL;
88          WHEN OTHERS =>
89               FAILED ( "WRONG EXCEPTION RAISED - (A)" );
90     END;
91
92     BEGIN -- (B).
93          CHECK1 (CARR1A (C1B), "(B)");
94     EXCEPTION
95          WHEN CONSTRAINT_ERROR =>
96               NULL;
97          WHEN OTHERS =>
98               FAILED ( "WRONG EXCEPTION RAISED - (B)" );
99     END;
100
101     BEGIN -- (C).
102          C1B := C1A;
103          CHECK1 (C1B, "(C)");
104     EXCEPTION
105          WHEN CONSTRAINT_ERROR =>
106               NULL;
107          WHEN OTHERS =>
108               FAILED ( "WRONG EXCEPTION RAISED - (C)" );
109     END;
110
111     BEGIN -- (D).
112          CHECK1 (CARR1B (C1A), "(D)");
113     EXCEPTION
114          WHEN CONSTRAINT_ERROR =>
115               NULL;
116          WHEN OTHERS =>
117               FAILED ( "WRONG EXCEPTION RAISED - (D)" );
118     END;
119
120     BEGIN -- (E).
121          C1A := C1N;
122          CHECK1 (C1A, "(E)");
123     EXCEPTION
124          WHEN CONSTRAINT_ERROR =>
125               NULL;
126          WHEN OTHERS =>
127               FAILED ( "WRONG EXCEPTION RAISED - (E)" );
128     END;
129
130     BEGIN -- (F).
131          CHECK1 (CARR1A (C1N), "(F)");
132     EXCEPTION
133          WHEN CONSTRAINT_ERROR =>
134               NULL;
135          WHEN OTHERS =>
136               FAILED ( "WRONG EXCEPTION RAISED - (F)" );
137     END;
138
139     BEGIN -- (G).
140          C2A := C2B;
141          CHECK2 (C2A, "(G)");
142     EXCEPTION
143          WHEN CONSTRAINT_ERROR =>
144               NULL;
145          WHEN OTHERS =>
146               FAILED ( "WRONG EXCEPTION RAISED - (G)" );
147     END;
148
149     BEGIN -- (H).
150          CHECK2 (CARR2A (C2B), "(H)");
151     EXCEPTION
152          WHEN CONSTRAINT_ERROR =>
153               NULL;
154          WHEN OTHERS =>
155               FAILED ( "WRONG EXCEPTION RAISED - (H)" );
156     END;
157
158     BEGIN -- (I).
159          C2B := C2A;
160          CHECK2 (C2B, "(I)");
161     EXCEPTION
162          WHEN CONSTRAINT_ERROR =>
163               NULL;
164          WHEN OTHERS =>
165               FAILED ( "WRONG EXCEPTION RAISED - (I)" );
166     END;
167
168     BEGIN -- (J).
169          CHECK2 (CARR2A (C2B), "(J)");
170     EXCEPTION
171          WHEN CONSTRAINT_ERROR =>
172               NULL;
173          WHEN OTHERS =>
174               FAILED ( "WRONG EXCEPTION RAISED - (J)" );
175     END;
176
177     BEGIN -- (K).
178          C2A := C2N;
179          CHECK2 (C2A, "(K)");
180     EXCEPTION
181          WHEN CONSTRAINT_ERROR =>
182               NULL;
183          WHEN OTHERS =>
184               FAILED ( "WRONG EXCEPTION RAISED - (K)" );
185     END;
186
187     BEGIN -- (L).
188          CHECK2 (CARR2A (C2N), "(L)");
189     EXCEPTION
190          WHEN CONSTRAINT_ERROR =>
191               NULL;
192          WHEN OTHERS =>
193               FAILED ( "WRONG EXCEPTION RAISED - (L)" );
194     END;
195
196     BEGIN -- (M).
197          C1N := C1A;
198          CHECK1 (C1N, "(M)");
199     EXCEPTION
200          WHEN CONSTRAINT_ERROR =>
201               NULL;
202          WHEN OTHERS =>
203               FAILED ( "WRONG EXCEPTION RAISED - (M)" );
204     END;
205
206     BEGIN -- (N).
207          CHECK1 (CARR1N (C1A), "(N)");
208     EXCEPTION
209          WHEN CONSTRAINT_ERROR =>
210               NULL;
211          WHEN OTHERS =>
212               FAILED ( "WRONG EXCEPTION RAISED - (N)" );
213     END;
214
215     BEGIN -- (O).
216          C2N := C2A;
217          CHECK2 (C2N, "(O)");
218     EXCEPTION
219          WHEN CONSTRAINT_ERROR =>
220               NULL;
221          WHEN OTHERS =>
222               FAILED ( "WRONG EXCEPTION RAISED - (O)" );
223     END;
224
225     BEGIN -- (P).
226          CHECK2 (CARR2N (C2A), "(P)");
227     EXCEPTION
228          WHEN CONSTRAINT_ERROR =>
229               NULL;
230          WHEN OTHERS =>
231               FAILED ( "WRONG EXCEPTION RAISED - (P)" );
232     END;
233
234     RESULT;
235END C46044B;
236