1-- C48009B.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
26-- IS RAISED IF T IS AN UNCONSTRAINED RECORD OR PRIVATE TYPE, (X) IS AN
27-- AGGREGATE OR A VALUE OF TYPE T, AND ONE OF THE DISCRIMINANT VALUES IN
28-- X:
29--   1) DOES NOT SATISFY THE RANGE CONSTRAINT FOR THE CORRESPONDING
30--      DISCRIMINANT OF T.
31--   2) DOES NOT EQUAL THE DISCRIMINANT VALUE SPECIFIED IN THE
32--      DECLARATION OF THE ALLOCATOR'S BASE TYPE.
33--   3) A DISCRIMINANT VALUE IS COMPATIBLE WITH A DISCRIMINANT'S SUBTYPE
34--      BUT DOES NOT PROVIDE A COMPATIBLE INDEX OR DISCRIMINANT
35--      CONSTRAINT FOR A SUBCOMPONENT DEPENDENT ON THE DISCRIMINANT.
36
37-- RM  01/08/80
38-- NL  10/13/81
39-- SPS 10/26/82
40-- JBG 03/02/83
41-- EG  07/05/84
42
43WITH REPORT;
44
45PROCEDURE  C48009B  IS
46
47     USE REPORT;
48
49BEGIN
50
51     TEST( "C48009B" , "FOR ALLOCATORS OF THE FORM 'NEW T '(X)', " &
52                       "CHECK THAT CONSTRAINT_ERROR IS RAISED WHEN " &
53                       "APPROPRIATE - UNCONSTRAINED RECORD AND " &
54                       "PRIVATE TYPES");
55
56     DECLARE
57
58          SUBTYPE I1_7 IS INTEGER RANGE IDENT_INT(1)..IDENT_INT(7);
59          SUBTYPE I1_10 IS INTEGER RANGE IDENT_INT(1)..IDENT_INT(10);
60          SUBTYPE I2_9 IS INTEGER RANGE IDENT_INT(2)..IDENT_INT(9);
61
62          TYPE REC (A : I2_9) IS
63               RECORD
64                    NULL;
65               END RECORD;
66
67          TYPE ARR IS ARRAY (I2_9 RANGE <>) OF INTEGER;
68
69          TYPE T_REC (C : I1_10) IS
70               RECORD
71                    D : REC(C);
72               END RECORD;
73
74          TYPE T_ARR (C : I1_10) IS
75               RECORD
76                    D : ARR(2..C);
77                    E : ARR(C..9);
78               END RECORD;
79
80          TYPE T_REC_REC (A : I1_10) IS
81               RECORD
82                    B : T_REC(A);
83               END RECORD;
84
85          TYPE T_REC_ARR (A : I1_10) IS
86               RECORD
87                    B : T_ARR(A);
88               END RECORD;
89
90          TYPE  TB (  A : I1_7 )  IS
91               RECORD
92                    R : INTEGER;
93               END RECORD;
94
95          TYPE A_T_REC_REC IS ACCESS T_REC_REC;
96          TYPE A_T_REC_ARR IS ACCESS T_REC_ARR;
97          TYPE ATB IS ACCESS TB;
98          TYPE ACTB IS ACCESS TB(3);
99
100          VA_T_REC_REC : A_T_REC_REC;
101          VA_T_REC_ARR : A_T_REC_ARR;
102          VB  : ATB;
103          VCB : ACTB;
104
105          PACKAGE  P  IS
106               TYPE  PRIV( A : I1_10 )  IS PRIVATE;
107               CONS_PRIV : CONSTANT PRIV;
108          PRIVATE
109               TYPE  PRIV( A : I1_10 )  IS
110                    RECORD
111                         R : INTEGER;
112                    END RECORD;
113               CONS_PRIV : CONSTANT PRIV := (2, 3);
114          END P;
115
116          USE P;
117
118          TYPE  A_PRIV  IS  ACCESS P.PRIV;
119          TYPE  A_CPRIV IS  ACCESS P.PRIV (3);
120
121          VP  : A_PRIV;
122          VCP : A_CPRIV;
123
124          FUNCTION ALLOC1(X : P.PRIV) RETURN A_CPRIV IS
125          BEGIN
126               IF EQUAL(1, 1) THEN
127                    RETURN NEW P.PRIV'(X);
128               ELSE
129                    RETURN NULL;
130               END IF;
131          END ALLOC1;
132          FUNCTION ALLOC2(X : TB) RETURN ACTB IS
133          BEGIN
134               IF EQUAL(1, 1) THEN
135                    RETURN NEW TB'(X);
136               ELSE
137                    RETURN NULL;
138               END IF;
139          END ALLOC2;
140
141     BEGIN
142
143          BEGIN     -- B1
144               VB  :=  NEW TB'(A => IDENT_INT(0), R => 1);
145               FAILED ("NO EXCEPTION RAISED - CASE 1A");
146          EXCEPTION
147               WHEN  CONSTRAINT_ERROR  =>  NULL;
148               WHEN  OTHERS            =>
149                    FAILED( "WRONG EXCEPTION RAISED - CASE 1A" );
150          END;
151
152          BEGIN
153               VB  :=  NEW TB'(A => 8, R => 1);
154               FAILED ("NO EXCEPTION RAISED - CASE 1B");
155          EXCEPTION
156               WHEN  CONSTRAINT_ERROR  =>  NULL;
157               WHEN  OTHERS            =>
158                    FAILED( "WRONG EXCEPTION RAISED - CASE 1B");
159          END; -- B1
160
161          BEGIN     -- B2
162               VCB := NEW TB'(2, 3);
163               FAILED ("NO EXCEPTION RAISED - CASE 2A");
164          EXCEPTION
165               WHEN CONSTRAINT_ERROR => NULL;
166               WHEN OTHERS =>
167                    FAILED ("WRONG EXCEPTION RAISED - CASE 2A");
168          END;
169
170          BEGIN
171               IF ALLOC2((IDENT_INT(4), 3)) = NULL THEN
172                    FAILED ("IMPOSSIBLE - CASE 2B");
173               END IF;
174               FAILED ("NO EXCEPTION RAISED - CASE 2B");
175          EXCEPTION
176               WHEN CONSTRAINT_ERROR => NULL;
177               WHEN OTHERS =>
178                    FAILED ("WRONG EXCEPTION RAISED - CASE 2B");
179          END;
180
181          BEGIN
182
183               IF ALLOC1(CONS_PRIV) = NULL THEN
184                    FAILED ("IMPOSSIBLE - CASE 2C");
185               END IF;
186               FAILED ("NO EXCEPTION RAISED - CASE 2C");
187
188          EXCEPTION
189
190               WHEN CONSTRAINT_ERROR => NULL;
191               WHEN OTHERS =>
192                    FAILED ("WRONG EXCEPTION RAISED - CASE 2C");
193
194          END; -- B2
195
196          BEGIN     -- B3
197
198               VA_T_REC_REC := NEW T_REC_REC'(1, (1, (A => 1)));
199               FAILED ("NO EXCEPTION RAISED - CASE 3A");
200
201          EXCEPTION
202
203               WHEN CONSTRAINT_ERROR => NULL;
204               WHEN OTHERS =>
205                    FAILED ("WRONG EXCEPTION RAISED - CASE 3A");
206
207          END;
208
209          BEGIN
210
211               VA_T_REC_REC := NEW T_REC_REC'(10,
212                                             (10, (A => 10)));
213               FAILED ("NO EXCEPTION RAISED - CASE 3B");
214
215          EXCEPTION
216
217               WHEN CONSTRAINT_ERROR => NULL;
218               WHEN OTHERS =>
219                    FAILED ("WRONG EXCEPTION RAISED - CASE 3B");
220
221          END;
222
223          BEGIN
224
225               VA_T_REC_ARR := NEW T_REC_ARR'(1, (1, (OTHERS => 1),
226                                                     (OTHERS => 2)));
227               FAILED ("NO EXCEPTION RAISED - CASE 3C");
228
229          EXCEPTION
230
231               WHEN CONSTRAINT_ERROR => NULL;
232               WHEN OTHERS =>
233                    FAILED ("WRONG EXCEPTION RAISED - CASE 3C");
234
235          END;
236
237          BEGIN
238
239               VA_T_REC_ARR := NEW T_REC_ARR'(10, (10, (OTHERS => 1),
240                                                       (OTHERS => 2)));
241               FAILED ("NO EXCEPTION RAISED - CASE 3D");
242
243          EXCEPTION
244
245               WHEN CONSTRAINT_ERROR => NULL;
246               WHEN OTHERS =>
247                    FAILED ("WRONG EXCEPTION RAISED - CASE 3D");
248
249          END;
250
251     END;
252
253     RESULT;
254
255END C48009B;
256