1-- C48008A.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-- FOR ALLOCATORS OF THE FORM "NEW T X", CHECK THAT CONSTRAINT_ERROR IS
26-- RAISED IF T IS AN UNCONSTRAINED RECORD, PRIVATE, OR LIMITED TYPE, X
27-- IS A DISCRIMINANT CONSTRAINT, AND
28--   1) ONE OF THE VALUES OF X IS OUTSIDE THE RANGE OF THE CORRESPONDING
29--      DISCRIMINANT;
30--   2) ONE OF THE DISCRIMINANT VALUES IS NOT COMPATIBLE WITH A
31--      CONSTRAINT OF A SUBCOMPONENT IN WHICH IT IS USED;
32--   3) ONE OF THE DISCRIMINANT VALUES DOES NOT EQUAL THE CORRESPONDING
33--      VALUE OF THE ALLOCATOR'S BASE TYPE;
34--   4) A DEFAULT INITIALIZATION RAISES AN EXCEPTION.
35
36-- RM  01/08/80
37-- NL  10/13/81
38-- SPS 10/26/82
39-- JBG 03/02/83
40-- EG  07/05/84
41-- PWB 02/05/86  CORRECTED TEST ERROR:
42--               CHANGED "FAILED" TO "COMMENT" IN PROCEDURE INCR_CHECK,
43--               SO AS NOT TO PROHIBIT EVAL OF DEFLT EXPR (AI-00397/01)
44--               ADDED COMMENTS FOR CASES.
45
46WITH REPORT;
47
48PROCEDURE  C48008A  IS
49
50     USE REPORT;
51
52BEGIN
53
54     TEST( "C48008A" , "FOR ALLOCATORS OF THE FORM 'NEW T X', " &
55                       "CHECK THAT CONSTRAINT_ERROR IS RAISED WHEN " &
56                       "APPROPRIATE - UNCONSTRAINED RECORD AND " &
57                       "PRIVATE TYPES");
58
59     DECLARE
60
61          DISC_FLAG : BOOLEAN := FALSE;
62          INCR_VAL : INTEGER;
63          FUNCTION INCR(A : INTEGER) RETURN INTEGER;
64
65          SUBTYPE I1_7 IS INTEGER RANGE IDENT_INT(1)..IDENT_INT(7);
66          SUBTYPE I1_10 IS INTEGER RANGE IDENT_INT(1)..IDENT_INT(10);
67          SUBTYPE I2_9 IS INTEGER RANGE IDENT_INT(2)..IDENT_INT(9);
68
69          TYPE REC (A : I2_9) IS
70               RECORD
71                    B : INTEGER := INCR(2);
72               END RECORD;
73
74          TYPE ARR IS ARRAY (I2_9 RANGE <>) OF INTEGER;
75
76          TYPE T_REC (C : I1_10) IS
77               RECORD
78                    D : REC(C);
79               END RECORD;
80
81          TYPE T_ARR (C : I1_10) IS
82               RECORD
83                    D : ARR(2..C);
84                    E : ARR(C..9);
85               END RECORD;
86
87          TYPE T_REC_REC (A : I1_10) IS
88               RECORD
89                    B : T_REC(A);
90               END RECORD;
91
92          TYPE T_REC_ARR (A : I1_10) IS
93               RECORD
94                    B : T_ARR(A);
95               END RECORD;
96
97          TYPE  TB (  A : I1_7 )  IS
98               RECORD
99                    R : INTEGER := INCR(1);
100               END RECORD;
101
102          TYPE UR (A : INTEGER) IS
103               RECORD
104                    B : I2_9 := INCR(1);
105               END RECORD;
106
107          TYPE A_T_REC_REC IS ACCESS T_REC_REC;
108          TYPE A_T_REC_ARR IS ACCESS T_REC_ARR;
109          TYPE ATB IS ACCESS TB;
110          TYPE ACTB IS ACCESS TB(3);
111          TYPE A_UR IS ACCESS UR;
112
113          VA_T_REC_REC : A_T_REC_REC;
114          VA_T_REC_ARR : A_T_REC_ARR;
115          VB  : ATB;
116          VCB : ACTB;
117          V_A_UR : A_UR;
118
119          BOOL : BOOLEAN;
120
121          FUNCTION DISC (A : INTEGER) RETURN INTEGER;
122
123
124          PACKAGE  P  IS
125               TYPE  PRIV( A : I1_10 := DISC(8) )  IS PRIVATE;
126               CONS_PRIV : CONSTANT PRIV;
127          PRIVATE
128               TYPE  PRIV( A : I1_10 := DISC(8) )  IS
129                    RECORD
130                         R : INTEGER := INCR(1);
131                    END RECORD;
132               CONS_PRIV : CONSTANT PRIV := (2, 3);
133          END P;
134
135          TYPE  A_PRIV  IS  ACCESS P.PRIV;
136          TYPE  A_CPRIV IS  ACCESS P.PRIV (3);
137
138          VP  : A_PRIV;
139          VCP : A_CPRIV;
140
141          PROCEDURE PREC_REC (X : A_T_REC_REC) IS
142          BEGIN
143               NULL;
144          END PREC_REC;
145
146          PROCEDURE PREC_ARR (X : A_T_REC_ARR) IS
147          BEGIN
148               NULL;
149          END PREC_ARR;
150
151          PROCEDURE PB (X : ATB) IS
152          BEGIN
153               NULL;
154          END PB;
155
156          PROCEDURE PCB (X : ACTB) IS
157          BEGIN
158               NULL;
159          END PCB;
160
161          PROCEDURE PPRIV (X : A_PRIV) IS
162          BEGIN
163               NULL;
164          END PPRIV;
165
166          PROCEDURE PCPRIV (X : A_CPRIV) IS
167          BEGIN
168               NULL;
169          END PCPRIV;
170
171          FUNCTION DISC (A : INTEGER) RETURN INTEGER IS
172          BEGIN
173               DISC_FLAG := TRUE;
174               RETURN A;
175          END DISC;
176
177          FUNCTION INCR(A : INTEGER) RETURN INTEGER IS
178          BEGIN
179               INCR_VAL := IDENT_INT(INCR_VAL+1);
180               RETURN A;
181          END INCR;
182
183          PROCEDURE INCR_CHECK(CASE_ID : STRING) IS
184          BEGIN
185               IF INCR_VAL /= IDENT_INT(0) THEN
186                    COMMENT ("DEFAULT INITIAL VALUE WAS EVALUATED - " &
187                             "CASE " & CASE_ID);
188               END IF;
189          END INCR_CHECK;
190
191     BEGIN
192
193          BEGIN  -- A1A: 0 ILLEGAL FOR TB.A.
194               INCR_VAL := 0;
195               VB  :=  NEW TB (A => 0);
196               FAILED ("NO EXCEPTION RAISED - CASE A1A");
197          EXCEPTION
198               WHEN  CONSTRAINT_ERROR  =>
199                    INCR_CHECK("A1A");
200               WHEN  OTHERS            =>
201                    FAILED( "WRONG EXCEPTION RAISED - CASE A1A" );
202          END;   -- A1A
203
204          BEGIN  -- A1B: 8 ILLEGAL IN I1_7.
205               INCR_VAL := 0;
206               VB  :=  NEW TB (A => I1_7'(IDENT_INT(8)));
207               FAILED ("NO EXCEPTION RAISED - CASE A1B");
208          EXCEPTION
209               WHEN  CONSTRAINT_ERROR  =>
210                    INCR_CHECK("A1B");
211               WHEN  OTHERS            =>
212                    FAILED( "WRONG EXCEPTION RAISED - CASE A1B");
213          END;   -- A1B
214
215          BEGIN  -- A1C: 8 ILLEGAL FOR TB.A.
216               INCR_VAL := 0;
217               PB(NEW TB (A => 8));
218               FAILED ("NO EXCEPTION RAISED - CASE A1C");
219          EXCEPTION
220               WHEN  CONSTRAINT_ERROR  =>
221                    INCR_CHECK("A1C");
222               WHEN  OTHERS            =>
223                    FAILED( "WRONG EXCEPTION RAISED - CASE A1C");
224          END;   --A1C
225
226          BEGIN  --A1D: 0 ILLEGAL FOR TB.A.
227               INCR_VAL := 0;
228               BOOL := ATB'(NEW TB(A => 0)) = NULL;
229               FAILED ("NO EXCEPTION RAISED - CASE A1D");
230          EXCEPTION
231               WHEN  CONSTRAINT_ERROR  =>
232                    INCR_CHECK("A1D");
233               WHEN  OTHERS            =>
234                    FAILED( "WRONG EXCEPTION RAISED - CASE A1D");
235          END;   --A1D
236
237          BEGIN  --A1E: 11 ILLEGAL FOR PRIV.A.
238               DISC_FLAG := FALSE;
239               INCR_VAL := 0;
240               VP := NEW P.PRIV(11);
241               FAILED("NO EXCEPTION RAISED - CASE A1E");
242          EXCEPTION
243               WHEN CONSTRAINT_ERROR =>
244                    IF DISC_FLAG THEN
245                         FAILED ("DISCR DEFAULT EVALUATED WHEN " &
246                                 "EXPLICIT VALUE WAS PROVIDED - A1E");
247                    END IF;
248                    INCR_CHECK("A1E");
249               WHEN OTHERS           =>
250                    FAILED("WRONG EXCEPTION RAISED - CASE A1E");
251          END;   -- A1E
252
253          BEGIN  -- A2A: 1 ILLEGAL FOR REC.A.
254               INCR_VAL := 0;
255               VA_T_REC_REC := NEW T_REC_REC(A => I1_10'(IDENT_INT(1)));
256               FAILED ("NO EXCEPTION RAISED - CASE A2A");
257          EXCEPTION
258               WHEN CONSTRAINT_ERROR =>
259                    INCR_CHECK("A2A");
260               WHEN OTHERS =>
261                    FAILED ("WRONG EXCEPTION RAISED - CASE A2A");
262          END;   -- A2A
263
264          BEGIN  --A2B: 10 ILLEGAL FOR REC.A.
265               INCR_VAL := 0;
266               VA_T_REC_REC := NEW T_REC_REC (10);
267               FAILED ("NO EXCEPTION RAISED - CASE A2B");
268          EXCEPTION
269               WHEN CONSTRAINT_ERROR =>
270                    INCR_CHECK("A2B");
271               WHEN OTHERS =>
272                    FAILED ("WRONG EXCEPTION RAISED - CASE A2B");
273          END;   -- A2B
274
275          BEGIN  -- A2C: 1 ILLEGAL FOR T.ARR.E'FIRST.
276               INCR_VAL := 0;
277               PREC_ARR (NEW T_REC_ARR (1));
278               FAILED ("NO EXCEPTION RAISED - CASE A2C");
279          EXCEPTION
280               WHEN CONSTRAINT_ERROR =>
281                    INCR_CHECK ("A2C");
282               WHEN OTHERS =>
283                    FAILED ("WRONG EXCEPTION RAISED - CASE A2C");
284          END;   -- A2C
285
286          BEGIN  -- A2D: 10 ILLEGAL FOR T_ARR.D'LAST.
287               INCR_VAL := 0;
288               BOOL := NEW T_REC_ARR (IDENT_INT(10)) = NULL;
289               FAILED ("NO EXCEPTION RAISED - CASE A2D");
290          EXCEPTION
291               WHEN CONSTRAINT_ERROR =>
292                    INCR_CHECK ("A2D");
293               WHEN OTHERS =>
294                    FAILED ("WRONG EXCEPTION RAISED - CASE A2D");
295          END;   -- A2D
296
297          BEGIN -- A3A: ASSIGNMENT VIOLATES CONSTRAINT ON VCB'S SUBTYPE.
298               INCR_VAL := 0;
299               VCB := NEW TB (4);
300               FAILED ("NO EXCEPTION RAISED - CASE A3A");
301          EXCEPTION
302               WHEN CONSTRAINT_ERROR =>
303                    INCR_CHECK("A3A");
304               WHEN OTHERS =>
305                    FAILED ("WRONG EXCEPTION RAISED - CASE A3A");
306          END;   -- A3A
307
308          BEGIN  -- A3B: PARM ASSOC VIOLATES CONSTRAINT ON PARM SUBTYPE.
309               INCR_VAL := 0;
310               PCB (NEW TB (4));
311               FAILED ("NO EXCEPTION RAISED - CASE A3B");
312          EXCEPTION
313               WHEN CONSTRAINT_ERROR =>
314                    INCR_CHECK("A3B");
315               WHEN OTHERS =>
316                    FAILED ("WRONG EXCEPTION RAISED - CASE A3B");
317          END;   -- A3B
318
319          BEGIN  -- A3C: 2 VIOLATES CONSTRAINT ON SUBTYPE ACTB.
320               INCR_VAL := 0;
321               BOOL := ACTB'(NEW TB (IDENT_INT(2))) = NULL;
322               FAILED ("NO EXCEPTION RAISED - CASE A3C");
323          EXCEPTION
324               WHEN CONSTRAINT_ERROR =>
325                    INCR_CHECK("A3C");
326               WHEN OTHERS =>
327                    FAILED ("WRONG EXCEPTION RAISED - CASE A3C");
328          END;   -- A3C
329
330          BEGIN  -- A4A: EVALUATION OF DEFAULT RAISES EXCEPTION.
331               INCR_VAL := 0;
332               V_A_UR := NEW UR(4);
333               FAILED ("NO EXCEPTION RAISED - CASE A4A");
334          EXCEPTION
335               WHEN CONSTRAINT_ERROR =>
336                    NULL;
337               WHEN OTHERS =>
338                    FAILED ("WRONG EXCEPTION RAISED - CASE A4A");
339          END;   -- A4A
340
341     END;
342
343     RESULT;
344
345END C48008A;
346