Mercurial > hg > CbC > CbC_gcc

comparison gcc/testsuite/ada/acats/tests/c4/c48009b.ada @ 111:04ced10e8804

Find changesets by keywords (author, files, the commit message), revision number or hash, or revset expression.
gcc 7
author kono
date Fri, 27 Oct 2017 22:46:09 +0900
parents
children
comparison
equal deleted inserted replaced
68:561a7518be6b 111:04ced10e8804
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
43 WITH REPORT;
44
45 PROCEDURE C48009B IS
46
47 USE REPORT;
48
49 BEGIN
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
255 END C48009B;