111
|
1 -- C37211B.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 BY A DISCRIMINANT CONSTRAINT
|
|
26 -- IF A VALUE SPECIFIED FOR A DISCRIMINANT DOES NOT LIE IN THE RANGE
|
|
27 -- OF THE DISCRIMINANT. THIS TEST CONTAINS CHECKS FOR SUBTYPE
|
|
28 -- INDICATIONS WHERE THE TYPE MARK DENOTES A PRIVATE OR LIMITED
|
|
29 -- PRIVATE TYPE, AND THE DISCRIMINANT CONSTRAINT OCCURS AFTER THE FULL
|
|
30 -- DECLARATION OF THE TYPE.
|
|
31
|
|
32 -- R.WILLIAMS 8/28/86
|
|
33 -- EDS 7/14/98 AVOID OPTIMIZATION
|
|
34
|
|
35 WITH REPORT; USE REPORT;
|
|
36 PROCEDURE C37211B IS
|
|
37
|
|
38 SUBTYPE LIES IS BOOLEAN RANGE FALSE .. FALSE;
|
|
39
|
|
40 PACKAGE PKG IS
|
|
41 TYPE PRIV (L : LIES) IS PRIVATE;
|
|
42 TYPE LIM (L : LIES) IS LIMITED PRIVATE;
|
|
43
|
|
44 PRIVATE
|
|
45 TYPE PRIV (L : LIES) IS
|
|
46 RECORD
|
|
47 NULL;
|
|
48 END RECORD;
|
|
49
|
|
50 TYPE LIM (L : LIES) IS
|
|
51 RECORD
|
|
52 NULL;
|
|
53 END RECORD;
|
|
54 END PKG;
|
|
55
|
|
56 USE PKG;
|
|
57
|
|
58 BEGIN
|
|
59 TEST ( "C37211B", "CHECK THAT CONSTRAINT_ERROR IS RAISED BY " &
|
|
60 "A DISCRIMINANT CONSTRAINT IF A VALUE " &
|
|
61 "SPECIFIED FOR A DISCRIMINANT DOES NOT LIE " &
|
|
62 "IN THE RANGE OF THE DISCRIMINANT WHERE THE " &
|
|
63 "TYPE MARK DENOTES A PRIVATE OR LIMITED " &
|
|
64 "PRIVATE TYPE, AND THE DISCRIMINANT " &
|
|
65 "CONSTRAINT OCCURS AFTER THE FULL " &
|
|
66 "DECLARATION OF THE TYPE" );
|
|
67
|
|
68 BEGIN
|
|
69 DECLARE
|
|
70 SUBTYPE SUBPRIV IS PRIV (IDENT_BOOL (TRUE));
|
|
71 BEGIN
|
|
72 DECLARE
|
|
73 SP : SUBPRIV;
|
|
74 BEGIN
|
|
75 FAILED ( "NO EXCEPTION RAISED AT THE " &
|
|
76 "ELABORATION OF SUBTYPE SUBPRIV " &
|
|
77 BOOLEAN'IMAGE(SP.L));
|
|
78 END;
|
|
79 EXCEPTION
|
|
80 WHEN OTHERS =>
|
|
81 FAILED ( "EXCEPTION RAISED AT DECLARATION OF " &
|
|
82 "OBJECT SP" );
|
|
83 END;
|
|
84
|
|
85 EXCEPTION
|
|
86 WHEN CONSTRAINT_ERROR =>
|
|
87 NULL;
|
|
88 WHEN OTHERS =>
|
|
89 FAILED ( "WRONG EXCEPTION RAISED AT ELABORATION OF " &
|
|
90 "SUBTYPE SUBPRIV" );
|
|
91 END;
|
|
92
|
|
93 BEGIN
|
|
94 DECLARE
|
|
95 SUBTYPE SUBLIM IS LIM (IDENT_BOOL (TRUE));
|
|
96 BEGIN
|
|
97 DECLARE
|
|
98 SL : SUBLIM;
|
|
99 BEGIN
|
|
100 FAILED ( "NO EXCEPTION RAISED AT THE " &
|
|
101 "ELABORATION OF SUBTYPE SUBLIM" &
|
|
102 BOOLEAN'IMAGE(SL.L));
|
|
103 END;
|
|
104 EXCEPTION
|
|
105 WHEN OTHERS =>
|
|
106 FAILED ( "EXCEPTION RAISED AT DECLARATION OF " &
|
|
107 "OBJECT SL " );
|
|
108 END;
|
|
109
|
|
110 EXCEPTION
|
|
111 WHEN CONSTRAINT_ERROR =>
|
|
112 NULL;
|
|
113 WHEN OTHERS =>
|
|
114 FAILED ( "WRONG EXCEPTION RAISED AT ELABORATION OF " &
|
|
115 "SUBTYPE SUBLIM" );
|
|
116 END;
|
|
117
|
|
118 BEGIN
|
|
119 DECLARE
|
|
120 TYPE PARR IS ARRAY (1 .. 5) OF PRIV (IDENT_BOOL (TRUE));
|
|
121 BEGIN
|
|
122 DECLARE
|
|
123 PAR : PARR;
|
|
124 BEGIN
|
|
125 FAILED ( "NO EXCEPTION RAISED AT THE " &
|
|
126 "ELABORATION OF TYPE PARR " &
|
|
127 BOOLEAN'IMAGE(PAR(1).L));
|
|
128 END;
|
|
129 EXCEPTION
|
|
130 WHEN OTHERS =>
|
|
131 FAILED ( "EXCEPTION RAISED AT DECLARATION OF " &
|
|
132 "OBJECT PAR" );
|
|
133 END;
|
|
134
|
|
135 EXCEPTION
|
|
136 WHEN CONSTRAINT_ERROR =>
|
|
137 NULL;
|
|
138 WHEN OTHERS =>
|
|
139 FAILED ( "WRONG EXCEPTION RAISED AT ELABORATION OF " &
|
|
140 "TYPE PARR" );
|
|
141 END;
|
|
142
|
|
143 BEGIN
|
|
144 DECLARE
|
|
145 TYPE LARR IS ARRAY (1 .. 10) OF LIM (IDENT_BOOL (TRUE));
|
|
146 BEGIN
|
|
147 DECLARE
|
|
148 LAR : LARR;
|
|
149 BEGIN
|
|
150 FAILED ( "NO EXCEPTION RAISED AT THE " &
|
|
151 "ELABORATION OF TYPE LARR " &
|
|
152 BOOLEAN'IMAGE(LAR(1).L));
|
|
153 END;
|
|
154 EXCEPTION
|
|
155 WHEN OTHERS =>
|
|
156 FAILED ( "EXCEPTION RAISED AT DECLARATION OF " &
|
|
157 "OBJECT LAR" );
|
|
158 END;
|
|
159
|
|
160 EXCEPTION
|
|
161 WHEN CONSTRAINT_ERROR =>
|
|
162 NULL;
|
|
163 WHEN OTHERS =>
|
|
164 FAILED ( "WRONG EXCEPTION RAISED AT ELABORATION OF " &
|
|
165 "TYPE LARR" );
|
|
166 END;
|
|
167
|
|
168 BEGIN
|
|
169 DECLARE
|
|
170 TYPE PRIV1 IS
|
|
171 RECORD
|
|
172 X : PRIV (IDENT_BOOL (TRUE));
|
|
173 END RECORD;
|
|
174
|
|
175 BEGIN
|
|
176 DECLARE
|
|
177 P1 : PRIV1;
|
|
178 BEGIN
|
|
179 FAILED ( "NO EXCEPTION RAISED AT THE " &
|
|
180 "ELABORATION OF TYPE PRIV1 " &
|
|
181 BOOLEAN'IMAGE(P1.X.L));
|
|
182 END;
|
|
183 EXCEPTION
|
|
184 WHEN OTHERS =>
|
|
185 FAILED ( "EXCEPTION RAISED AT DECLARATION OF " &
|
|
186 "OBJECT P1" );
|
|
187 END;
|
|
188
|
|
189 EXCEPTION
|
|
190 WHEN CONSTRAINT_ERROR =>
|
|
191 NULL;
|
|
192 WHEN OTHERS =>
|
|
193 FAILED ( "WRONG EXCEPTION RAISED AT ELABORATION OF " &
|
|
194 "TYPE PRIV1" );
|
|
195 END;
|
|
196
|
|
197 BEGIN
|
|
198 DECLARE
|
|
199 TYPE LIM1 IS
|
|
200 RECORD
|
|
201 X : LIM (IDENT_BOOL (TRUE));
|
|
202 END RECORD;
|
|
203
|
|
204 BEGIN
|
|
205 DECLARE
|
|
206 L1 : LIM1;
|
|
207 BEGIN
|
|
208 FAILED ( "NO EXCEPTION RAISED AT THE " &
|
|
209 "ELABORATION OF TYPE LIM1 " &
|
|
210 BOOLEAN'IMAGE(L1.X.L));
|
|
211 END;
|
|
212 EXCEPTION
|
|
213 WHEN OTHERS =>
|
|
214 FAILED ( "EXCEPTION RAISED AT DECLARATION OF " &
|
|
215 "OBJECT L1" );
|
|
216 END;
|
|
217
|
|
218 EXCEPTION
|
|
219 WHEN CONSTRAINT_ERROR =>
|
|
220 NULL;
|
|
221 WHEN OTHERS =>
|
|
222 FAILED ( "WRONG EXCEPTION RAISED AT ELABORATION OF " &
|
|
223 "TYPE LIM1" );
|
|
224 END;
|
|
225
|
|
226 BEGIN
|
|
227 DECLARE
|
|
228 TYPE ACCPRIV IS ACCESS PRIV (IDENT_BOOL (TRUE));
|
|
229 BEGIN
|
|
230 DECLARE
|
|
231 ACP : ACCPRIV;
|
|
232 BEGIN
|
|
233 FAILED ( "NO EXCEPTION RAISED AT THE " &
|
|
234 "ELABORATION OF TYPE ACCPRIV " &
|
|
235 BOOLEAN'IMAGE(ACP.L));
|
|
236 END;
|
|
237 EXCEPTION
|
|
238 WHEN OTHERS =>
|
|
239 FAILED ( "EXCEPTION RAISED AT DECLARATION OF " &
|
|
240 "OBJECT ACP" );
|
|
241 END;
|
|
242
|
|
243 EXCEPTION
|
|
244 WHEN CONSTRAINT_ERROR =>
|
|
245 NULL;
|
|
246 WHEN OTHERS =>
|
|
247 FAILED ( "WRONG EXCEPTION RAISED AT ELABORATION OF " &
|
|
248 "TYPE ACCPRIV" );
|
|
249 END;
|
|
250
|
|
251 BEGIN
|
|
252 DECLARE
|
|
253 TYPE ACCLIM IS ACCESS LIM (IDENT_BOOL (TRUE));
|
|
254 BEGIN
|
|
255 DECLARE
|
|
256 ACL : ACCLIM;
|
|
257 BEGIN
|
|
258 FAILED ( "NO EXCEPTION RAISED AT THE " &
|
|
259 "ELABORATION OF TYPE ACCLIM " &
|
|
260 BOOLEAN'IMAGE(ACL.L));
|
|
261 END;
|
|
262 EXCEPTION
|
|
263 WHEN OTHERS =>
|
|
264 FAILED ( "EXCEPTION RAISED AT DECLARATION OF " &
|
|
265 "OBJECT ACL" );
|
|
266 END;
|
|
267
|
|
268 EXCEPTION
|
|
269 WHEN CONSTRAINT_ERROR =>
|
|
270 NULL;
|
|
271 WHEN OTHERS =>
|
|
272 FAILED ( "WRONG EXCEPTION RAISED AT ELABORATION OF " &
|
|
273 "TYPE ACCLIM" );
|
|
274 END;
|
|
275
|
|
276 BEGIN
|
|
277 DECLARE
|
|
278 TYPE NEWPRIV IS NEW PRIV (IDENT_BOOL (TRUE));
|
|
279 BEGIN
|
|
280 DECLARE
|
|
281 NP : NEWPRIV;
|
|
282 BEGIN
|
|
283 FAILED ( "NO EXCEPTION RAISED AT THE " &
|
|
284 "ELABORATION OF TYPE NEWPRIV " &
|
|
285 BOOLEAN'IMAGE(NP.L));
|
|
286 END;
|
|
287 EXCEPTION
|
|
288 WHEN OTHERS =>
|
|
289 FAILED ( "EXCEPTION RAISED AT DECLARATION OF " &
|
|
290 "OBJECT NP" );
|
|
291 END;
|
|
292
|
|
293 EXCEPTION
|
|
294 WHEN CONSTRAINT_ERROR =>
|
|
295 NULL;
|
|
296 WHEN OTHERS =>
|
|
297 FAILED ( "WRONG EXCEPTION RAISED AT ELABORATION OF " &
|
|
298 "TYPE NEWPRIV" );
|
|
299 END;
|
|
300
|
|
301 BEGIN
|
|
302 DECLARE
|
|
303 TYPE NEWLIM IS NEW LIM (IDENT_BOOL (TRUE));
|
|
304 BEGIN
|
|
305 DECLARE
|
|
306 NL : NEWLIM;
|
|
307 BEGIN
|
|
308 FAILED ( "NO EXCEPTION RAISED AT THE " &
|
|
309 "ELABORATION OF TYPE NEWLIM " &
|
|
310 BOOLEAN'IMAGE(NL.L));
|
|
311 END;
|
|
312 EXCEPTION
|
|
313 WHEN OTHERS =>
|
|
314 FAILED ( "EXCEPTION RAISED AT DECLARATION OF " &
|
|
315 "OBJECT NL" );
|
|
316 END;
|
|
317
|
|
318 EXCEPTION
|
|
319 WHEN CONSTRAINT_ERROR =>
|
|
320 NULL;
|
|
321 WHEN OTHERS =>
|
|
322 FAILED ( "WRONG EXCEPTION RAISED AT ELABORATION OF " &
|
|
323 "TYPE NEWLIM" );
|
|
324 END;
|
|
325
|
|
326 BEGIN
|
|
327 DECLARE
|
|
328 P : PRIV (IDENT_BOOL (TRUE));
|
|
329 BEGIN
|
|
330 FAILED ( "NO EXCEPTION RAISED AT THE DECLARATION OF " &
|
|
331 "P " & BOOLEAN'IMAGE(P.L));
|
|
332 EXCEPTION
|
|
333 WHEN OTHERS =>
|
|
334 FAILED ( "EXCEPTION RAISED INSIDE BLOCK " &
|
|
335 "CONTAINING P" );
|
|
336 END;
|
|
337
|
|
338 EXCEPTION
|
|
339 WHEN CONSTRAINT_ERROR =>
|
|
340 NULL;
|
|
341 WHEN OTHERS =>
|
|
342 FAILED ( "WRONG EXCEPTION RAISED AT DECLARATION OF " &
|
|
343 "P" );
|
|
344 END;
|
|
345
|
|
346 BEGIN
|
|
347 DECLARE
|
|
348 L : LIM (IDENT_BOOL (TRUE));
|
|
349 BEGIN
|
|
350 FAILED ( "NO EXCEPTION RAISED AT THE DECLARATION OF " &
|
|
351 "L " & BOOLEAN'IMAGE(L.L));
|
|
352 EXCEPTION
|
|
353 WHEN OTHERS =>
|
|
354 FAILED ( "EXCEPTION RAISED INSIDE BLOCK " &
|
|
355 "CONTAINING L" );
|
|
356 END;
|
|
357
|
|
358 EXCEPTION
|
|
359 WHEN CONSTRAINT_ERROR =>
|
|
360 NULL;
|
|
361 WHEN OTHERS =>
|
|
362 FAILED ( "WRONG EXCEPTION RAISED AT DECLARATION OF " &
|
|
363 "L" );
|
|
364 END;
|
|
365
|
|
366 BEGIN
|
|
367 DECLARE
|
|
368 TYPE PRIV_NAME IS ACCESS PRIV;
|
|
369 BEGIN
|
|
370 DECLARE
|
|
371 PN : PRIV_NAME := NEW PRIV (IDENT_BOOL (TRUE));
|
|
372 BEGIN
|
|
373 FAILED ( "NO EXCEPTION RAISED AT THE " &
|
|
374 "DECLARATION OF OBJECT PN " &
|
|
375 BOOLEAN'IMAGE(PN.L));
|
|
376 EXCEPTION
|
|
377 WHEN OTHERS =>
|
|
378 FAILED ( "EXCEPTION ATTEMPTING TO USE OBJECT" );
|
|
379 END;
|
|
380 EXCEPTION
|
|
381 WHEN CONSTRAINT_ERROR =>
|
|
382 NULL;
|
|
383 WHEN OTHERS =>
|
|
384 FAILED ( "WRONG EXCEPTION RAISED AT DECLARATION " &
|
|
385 "OF OBJECT PN" );
|
|
386 END;
|
|
387 EXCEPTION
|
|
388 WHEN OTHERS =>
|
|
389 FAILED ( "EXCEPTION RAISED AT ELABORATION OF TYPE " &
|
|
390 "PRIV_NAME" );
|
|
391 END;
|
|
392
|
|
393 BEGIN
|
|
394 DECLARE
|
|
395 TYPE LIM_NAME IS ACCESS LIM;
|
|
396 BEGIN
|
|
397 DECLARE
|
|
398 LN : LIM_NAME := NEW LIM (IDENT_BOOL (TRUE));
|
|
399 BEGIN
|
|
400 FAILED ( "NO EXCEPTION RAISED AT THE " &
|
|
401 "DECLARATION OF OBJECT LN " &
|
|
402 BOOLEAN'IMAGE(LN.L));
|
|
403 EXCEPTION
|
|
404 WHEN OTHERS =>
|
|
405 FAILED ( "EXCEPTION ATTEMPTING TO USE OBJECT" );
|
|
406 END;
|
|
407 EXCEPTION
|
|
408 WHEN CONSTRAINT_ERROR =>
|
|
409 NULL;
|
|
410 WHEN OTHERS =>
|
|
411 FAILED ( "WRONG EXCEPTION RAISED AT DECLARATION " &
|
|
412 "OF OBJECT LN" );
|
|
413 END;
|
|
414 EXCEPTION
|
|
415 WHEN OTHERS =>
|
|
416 FAILED ( "EXCEPTION RAISED AT ELABORATION OF TYPE " &
|
|
417 "LIM_NAME" );
|
|
418 END;
|
|
419
|
|
420 BEGIN
|
|
421 DECLARE
|
|
422 PACKAGE PP IS
|
|
423 TYPE BAD_PRIV (D : LIES := IDENT_BOOL (TRUE)) IS
|
|
424 PRIVATE;
|
|
425 PRIVATE
|
|
426 TYPE BAD_PRIV (D : LIES := IDENT_BOOL (TRUE)) IS
|
|
427 RECORD
|
|
428 NULL;
|
|
429 END RECORD;
|
|
430 END PP;
|
|
431
|
|
432 USE PP;
|
|
433 BEGIN
|
|
434 DECLARE
|
|
435 BP : BAD_PRIV;
|
|
436 BEGIN
|
|
437 FAILED ( "NO EXCEPTION RAISED AT THE " &
|
|
438 "DECLARATION OF OBJECT BP " &
|
|
439 BOOLEAN'IMAGE(BP.D));
|
|
440 EXCEPTION
|
|
441 WHEN OTHERS =>
|
|
442 FAILED ( "EXCEPTION ATTEMPTING TO USE OBJECT" );
|
|
443 END;
|
|
444 EXCEPTION
|
|
445 WHEN CONSTRAINT_ERROR =>
|
|
446 NULL;
|
|
447 WHEN OTHERS =>
|
|
448 FAILED ( "WRONG EXCEPTION RAISED AT DECLARATION " &
|
|
449 "OF OBJECT BP" );
|
|
450 END;
|
|
451 EXCEPTION
|
|
452 WHEN OTHERS =>
|
|
453 FAILED ( "EXCEPTION RAISED AT ELABORATION OF TYPE " &
|
|
454 "BAD_PRIV" );
|
|
455 END;
|
|
456
|
|
457 BEGIN
|
|
458 DECLARE
|
|
459 PACKAGE PL IS
|
|
460 TYPE BAD_LIM (D : LIES := IDENT_BOOL (TRUE)) IS
|
|
461 LIMITED PRIVATE;
|
|
462 PRIVATE
|
|
463 TYPE BAD_LIM (D : LIES := IDENT_BOOL (TRUE)) IS
|
|
464 RECORD
|
|
465 NULL;
|
|
466 END RECORD;
|
|
467 END PL;
|
|
468
|
|
469 USE PL;
|
|
470 BEGIN
|
|
471 DECLARE
|
|
472 BL : BAD_LIM;
|
|
473 BEGIN
|
|
474 FAILED ( "NO EXCEPTION RAISED AT THE " &
|
|
475 "DECLARATION OF OBJECT BL " &
|
|
476 BOOLEAN'IMAGE(BL.D));
|
|
477 EXCEPTION
|
|
478 WHEN OTHERS =>
|
|
479 FAILED ( "EXCEPTION ATTEMPTING TO USE OBJECT" );
|
|
480 END;
|
|
481 EXCEPTION
|
|
482 WHEN CONSTRAINT_ERROR =>
|
|
483 NULL;
|
|
484 WHEN OTHERS =>
|
|
485 FAILED ( "WRONG EXCEPTION RAISED AT DECLARATION " &
|
|
486 "OF OBJECT BL" );
|
|
487 END;
|
|
488 EXCEPTION
|
|
489 WHEN OTHERS =>
|
|
490 FAILED ( "EXCEPTION RAISED AT ELABORATION OF TYPE " &
|
|
491 "BAD_LIM" );
|
|
492 END;
|
|
493
|
|
494 RESULT;
|
|
495 END C37211B;
|