1-- C34011B.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-- OBJECTIVE:
26--     CHECK THAT A DERIVED TYPE DECLARATION IS NOT CONSIDERED EXACTLY
27--     EQUIVALENT TO AN ANONYMOUS DECLARATION OF THE DERIVED TYPE
28--     FOLLOWED BY A SUBTYPE DECLARATION OF THE DERIVED SUBTYPE.  IN
29--     PARTICULAR, CHECK THAT CONSTRAINT_ERROR CAN BE RAISED WHEN THE
30--     SUBTYPE INDICATION OF THE DERIVED TYPE DECLARATION IS ELABORATED
31--     (EVEN THOUGH THE CONSTRAINT WOULD SATISFY THE DERIVED (BASE)
32--     TYPE).
33
34-- HISTORY:
35--     JRK 09/04/87  CREATED ORIGINAL TEST.
36--     EDS 07/29/98  AVOID OPTIMIZATION
37
38WITH REPORT; USE REPORT;
39
40PROCEDURE C34011B IS
41
42     SUBTYPE BOOL IS BOOLEAN RANGE FALSE .. FALSE;
43
44     SUBTYPE FLT IS FLOAT RANGE -10.0 .. 10.0;
45
46     SUBTYPE DUR IS DURATION RANGE 0.0 .. 10.0;
47
48     SUBTYPE INT IS INTEGER RANGE 0 .. 10;
49
50     TYPE ARR IS ARRAY (INT RANGE <>) OF INTEGER;
51
52     TYPE REC (D : INT := 0) IS
53          RECORD
54               I : INTEGER;
55          END RECORD;
56
57     PACKAGE PT IS
58          TYPE PRIV (D : POSITIVE := 1) IS PRIVATE;
59     PRIVATE
60          TYPE PRIV (D : POSITIVE := 1) IS
61               RECORD
62                    I : INTEGER;
63               END RECORD;
64     END PT;
65
66     USE PT;
67
68     TYPE ACC_ARR IS ACCESS ARR;
69
70     TYPE ACC_REC IS ACCESS REC;
71
72BEGIN
73     TEST ("C34011B", "CHECK THAT CONSTRAINT_ERROR CAN BE RAISED " &
74                      "WHEN THE SUBTYPE INDICATION OF A DERIVED TYPE " &
75                      "DECLARATION IS ELABORATED");
76
77     BEGIN
78          DECLARE
79            TYPE T IS NEW BOOL RANGE FALSE .. BOOL(IDENT_BOOL(TRUE));
80
81          BEGIN
82            DECLARE
83               -- DEFINE AN OBJECT OF TYPE T AND USE IT TO AVOID OPTIMIZATION
84               T1 : T := T(IDENT_BOOL(TRUE));
85            BEGIN
86               FAILED ("DID NOT RAISE CONSTRAINT_ERROR AT PROPER PLACE");
87            EXCEPTION
88               WHEN OTHERS =>
89                     FAILED ("DID NOT RAISE CONSTRAINT_ERROR" &
90                             " AT PROPER PLACE - BOOL " &
91                             T'IMAGE(T1) );   --USE T1);
92            END;
93
94            FAILED ("EXCEPTION NOT RAISED - BOOL");
95
96          EXCEPTION
97               WHEN OTHERS =>
98                    FAILED ("WRONG HANDLER ENTERED - BOOL");
99          END;
100
101     EXCEPTION
102          WHEN CONSTRAINT_ERROR =>
103               NULL;
104          WHEN OTHERS =>
105               FAILED ("WRONG EXCEPTION RAISED - BOOL");
106     END;
107
108     BEGIN
109          DECLARE
110            TYPE T IS NEW POSITIVE RANGE IDENT_INT (0) .. 10;
111
112          BEGIN
113            DECLARE
114               -- DEFINE AN OBJECT OF TYPE T AND USE IT TO AVOID OPTIMIZATION
115               T1 : T := T(IDENT_INT(1));
116            BEGIN
117                 FAILED ("DID NOT RAISE CONSTRAINT_ERROR AT PROPER PLACE");
118            EXCEPTION
119               WHEN OTHERS =>
120                     FAILED ("DID NOT RAISE CONSTRAINT_ERROR - POSITIVE " &
121                             T'IMAGE(T1)); --USE T1
122            END;
123            FAILED ("EXCEPTION NOT RAISED - POSITIVE" );
124          EXCEPTION
125               WHEN OTHERS =>
126                    FAILED ("WRONG HANDLER ENTERED - POSITIVE");
127          END;
128
129     EXCEPTION
130          WHEN CONSTRAINT_ERROR =>
131               NULL;
132          WHEN OTHERS =>
133               FAILED ("WRONG EXCEPTION RAISED - POSITIVE");
134     END;
135
136     BEGIN
137          DECLARE
138            TYPE T IS NEW FLT RANGE 0.0 .. FLT(IDENT_INT(20));
139
140          BEGIN
141            DECLARE
142               -- DEFINE AN OBJECT OF TYPE T AND USE IT TO AVOID OPTIMIZATION
143               T1 : T := T(IDENT_INT(0));
144            BEGIN
145               FAILED ("DID NOT RAISE CONSTRAINT_ERROR" &
146                       " AT PROPER PLACE " &
147                       T'IMAGE(T1) ); --USE T1
148
149            EXCEPTION
150               WHEN OTHERS =>
151                     FAILED ("DID NOT RAISE CONSTRAINT_ERROR" &
152                             " AT PROPER PLACE ");
153            END;
154            FAILED ("EXCEPTION NOT RAISED - FLT" );
155          EXCEPTION
156               WHEN OTHERS =>
157                    FAILED ("WRONG HANDLER ENTERED - FLT");
158          END;
159
160     EXCEPTION
161          WHEN CONSTRAINT_ERROR =>
162               NULL;
163          WHEN OTHERS =>
164               FAILED ("WRONG EXCEPTION RAISED - FLT");
165     END;
166
167     BEGIN
168          DECLARE
169            TYPE T IS NEW DUR RANGE DUR(IDENT_INT(-1)) .. 5.0;
170
171
172          BEGIN
173            DECLARE
174               -- DEFINE AN OBJECT OF TYPE T AND USE IT TO AVOID OPTIMIZATION
175               T1 : T := T(IDENT_INT(2));
176            BEGIN
177               FAILED ("DID NOT RAISE CONSTRAINT_ERROR" &
178                       " AT PROPER PLACE " &
179                       T'IMAGE(T1) );  -- USE T1
180            EXCEPTION
181               WHEN OTHERS =>
182                     FAILED ("DID NOT RAISE CONSTRAINT_ERROR AT PROPER PLACE");
183            END;
184            FAILED ("EXCEPTION NOT RAISED - DUR " );
185          EXCEPTION
186               WHEN OTHERS =>
187                    FAILED ("WRONG HANDLER ENTERED - DUR");
188          END;
189
190     EXCEPTION
191          WHEN CONSTRAINT_ERROR =>
192               NULL;
193          WHEN OTHERS =>
194               FAILED ("WRONG EXCEPTION RAISED - DUR");
195     END;
196
197     BEGIN
198          DECLARE
199            TYPE T IS NEW ARR (IDENT_INT (-1) .. 10);
200
201          BEGIN
202            DECLARE
203               -- DEFINE AN OBJECT OF TYPE T AND USE IT TO AVOID OPTIMIZATION
204               T1 : T := (OTHERS => IDENT_INT(3));
205            BEGIN
206               FAILED ("DID NOT RAISE CONSTRAINT_ERROR " &
207                       "AT PROPER PLACE " &
208                       INTEGER'IMAGE(T1(1)) ); --USE T1
209            EXCEPTION
210               WHEN OTHERS =>
211                     FAILED ("DID NOT RAISE CONSTRAINT_ERROR AT PROPER PLACE");
212            END;
213            FAILED ("EXCEPTION NOT RAISED - ARR " );
214          EXCEPTION
215               WHEN OTHERS =>
216                    FAILED ("WRONG HANDLER ENTERED - ARR");
217          END;
218
219     EXCEPTION
220          WHEN CONSTRAINT_ERROR =>
221               NULL;
222          WHEN OTHERS =>
223               FAILED ("WRONG EXCEPTION RAISED - ARR");
224     END;
225
226     BEGIN
227          DECLARE
228               TYPE T IS NEW REC (IDENT_INT (11));
229
230          BEGIN
231            DECLARE
232               -- DEFINE AN OBJECT OF TYPE T AND USE IT TO AVOID OPTIMIZATION
233               T1 : T;
234            BEGIN
235               FAILED ("DID NOT RAISE CONSTRAINT_ERROR AT PROPER PLACE");
236            EXCEPTION
237               WHEN OTHERS =>
238                     FAILED ("DID NOT RAISE CONSTRAINT_ERROR " &
239                             "AT PROPER PLACE " &
240                             INTEGER'IMAGE(T1.D) ); --USE T1
241            END;
242            FAILED ("EXCEPTION NOT RAISED - REC " );
243          EXCEPTION
244               WHEN OTHERS =>
245                    FAILED ("WRONG HANDLER ENTERED - REC");
246          END;
247
248     EXCEPTION
249          WHEN CONSTRAINT_ERROR =>
250               NULL;
251          WHEN OTHERS =>
252               FAILED ("WRONG EXCEPTION RAISED - REC");
253     END;
254
255     BEGIN
256          DECLARE
257               TYPE T IS NEW PRIV (IDENT_INT (0));  --RAISES C_E
258
259          BEGIN
260            DECLARE
261               -- DEFINE AN OBJECT OF TYPE T AND USE IT TO AVOID OPTIMIZATION
262               T1 : T;
263            BEGIN
264               FAILED ("DID NOT RAISE CONSTRAINT_ERROR AT PROPER PLACE");
265            EXCEPTION
266               WHEN OTHERS =>
267                     FAILED ("DID NOT RAISE CONSTRAINT_ERROR " &
268                             "AT PROPER PLACE " &
269                             INTEGER'IMAGE(T1.D) ); --USE T1
270            END;
271            FAILED ("EXCEPTION NOT RAISED - PRIV " );
272          EXCEPTION
273               WHEN OTHERS =>
274                    FAILED ("WRONG HANDLER ENTERED - PRIV");
275          END;
276
277     EXCEPTION
278          WHEN CONSTRAINT_ERROR =>
279               NULL;
280          WHEN OTHERS =>
281               FAILED ("WRONG EXCEPTION RAISED - PRIV");
282     END;
283
284     BEGIN
285          DECLARE
286            TYPE T IS NEW ACC_ARR (0 .. IDENT_INT (11));  --RAISES C_E
287
288          BEGIN
289            DECLARE
290               -- DEFINE AN OBJECT OF TYPE T AND USE IT TO AVOID OPTIMIZATION
291               T1 : T;
292            BEGIN
293               FAILED ("DID NOT RAISE CONSTRAINT_ERROR AT PROPER PLACE");
294            EXCEPTION
295               WHEN OTHERS =>
296                     FAILED ("DID NOT RAISE CONSTRAINT_ERROR " &
297                             "AT PROPER PLACE " &
298                             INTEGER'IMAGE(T1(1)) ); --USE T1
299            END;
300            FAILED ("EXCEPTION NOT RAISED - ACC_ARR " );
301          EXCEPTION
302               WHEN OTHERS =>
303                    FAILED ("WRONG HANDLER ENTERED - ACC_ARR");
304          END;
305
306     EXCEPTION
307          WHEN CONSTRAINT_ERROR =>
308               NULL;
309          WHEN OTHERS =>
310               FAILED ("WRONG EXCEPTION RAISED - ACC_ARR");
311     END;
312
313     BEGIN
314          DECLARE
315               TYPE T IS NEW ACC_REC (IDENT_INT (-1));  --RAISES C_E
316
317          BEGIN
318            DECLARE
319               -- DEFINE AN OBJECT OF TYPE T AND USE IT TO AVOID OPTIMIZATION
320               T1 : T;
321            BEGIN
322               FAILED ("DID NOT RAISE CONSTRAINT_ERROR AT PROPER PLACE");
323            EXCEPTION
324               WHEN OTHERS =>
325                     FAILED ("DID NOT RAISE CONSTRAINT_ERROR " &
326                             "AT PROPER PLACE " &
327                             INTEGER'IMAGE(T1.D) ); --USE T1
328            END;
329                FAILED ("EXCEPTION NOT RAISED - ACC_REC " );
330          EXCEPTION
331               WHEN OTHERS =>
332                    FAILED ("WRONG HANDLER ENTERED - ACC_REC");
333          END;
334
335     EXCEPTION
336          WHEN CONSTRAINT_ERROR =>
337               NULL;
338          WHEN OTHERS =>
339               FAILED ("WRONG EXCEPTION RAISED - ACC_REC");
340     END;
341
342     RESULT;
343END C34011B;
344