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
35WITH REPORT; USE REPORT;
36PROCEDURE 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
58BEGIN
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;
495END C37211B;
496