Mercurial > hg > CbC > CbC_gcc

comparison gcc/testsuite/ada/acats/tests/c6/c64106c.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 -- C64106C.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 ASSIGNMENTS TO FORMAL PARAMETERS OF UNCONSTRAINED
26 -- RECORD, PRIVATE, AND LIMITED PRIVATE TYPES WITH DEFAULT
27 -- CONSTRAINTS RAISE CONSTRAINT_ERROR IF THE ACTUAL PARAMETER IS
28 -- CONSTRAINED AND THE CONSTRAINT VALUES OF THE OBJECT BEING
29 -- ASSIGNED TO DO NOT SATISFY THOSE OF THE ACTUAL PARAMETER.
30
31 -- SUBTESTS ARE:
32 -- (A) CONSTRAINED ACTUAL PARAMETERS OF RECORD TYPE.
33 -- (B) CONSTRAINED ACTUAL PARAMETERS OF PRIVATE TYPE.
34 -- (C) CONSTRAINED ACTUAL PARAMETERS OF LIMITED PRIVATE TYPE.
35
36 -- DAS 1/16/81
37 -- VKG 1/7/83
38 -- CPP 8/9/84
39
40 WITH REPORT;
41 PROCEDURE C64106C IS
42
43 USE REPORT;
44
45 BEGIN
46
47 TEST ("C64106C", "CHECK ASSIGNMENTS TO FORMAL PARAMETERS OF " &
48 "UNCONSTRAINED TYPES (WITH DEFAULTS)");
49
50 --------------------------------------------------
51
52 DECLARE -- (A)
53
54 PACKAGE PKG IS
55
56 SUBTYPE INTRANGE IS INTEGER RANGE 0..31;
57
58 TYPE RECTYPE (CONSTRAINT : INTRANGE := 15) IS
59 RECORD
60 INTFLD : INTRANGE;
61 STRFLD : STRING(1..CONSTRAINT);
62 END RECORD;
63
64 REC91,REC92,REC93 : RECTYPE(9);
65 REC_OOPS : RECTYPE(4);
66
67 PROCEDURE P (REC1 : IN RECTYPE; REC2 : IN OUT RECTYPE;
68 REC3 : OUT RECTYPE);
69 END PKG;
70
71 PACKAGE BODY PKG IS
72
73 PROCEDURE P (REC1 : IN RECTYPE; REC2 : IN OUT RECTYPE;
74 REC3 : OUT RECTYPE) IS
75
76 PROCEDURE P1 (REC11 : IN RECTYPE;
77 REC12 : IN OUT RECTYPE;
78 REC13 : OUT RECTYPE) IS
79 BEGIN
80 IF (NOT REC11'CONSTRAINED) OR
81 (REC11.CONSTRAINT /= IDENT_INT(9)) THEN
82 FAILED ("CONSTRAINT ON RECORD " &
83 "TYPE IN PARAMETER " &
84 "NOT RECOGNIZED");
85 END IF;
86
87 BEGIN -- ASSIGNMENT TO IN OUT PARAMETER
88 REC12 := REC_OOPS;
89 FAILED ("CONSTRAINT ERROR NOT RAISED - " &
90 "A.1");
91 EXCEPTION
92 WHEN CONSTRAINT_ERROR =>
93 NULL;
94 WHEN OTHERS =>
95 FAILED ("WRONG EXCEPTION RAISED - " &
96 "A.1");
97 END;
98
99 BEGIN -- ASSIGNMENT TO OUT PARAMETER
100 REC13 := REC_OOPS;
101 FAILED ("CONSTRAINT_ERROR NOT RAISED - " &
102 "A.2");
103 EXCEPTION
104 WHEN CONSTRAINT_ERROR =>
105 NULL;
106 WHEN OTHERS =>
107 FAILED ("WRONG EXCEPTION RAISED - " &
108 "A.2");
109 END;
110 END P1;
111
112 BEGIN
113 P1 (REC1, REC2, REC3);
114 END P;
115
116 BEGIN
117
118 REC91 := (9, 9, "123456789");
119 REC92 := REC91;
120 REC93 := REC91;
121
122 REC_OOPS := (4, 4, "OOPS");
123
124 END PKG;
125
126 BEGIN -- (A)
127
128 PKG.P (PKG.REC91, PKG.REC92, PKG.REC93);
129
130 END; -- (A)
131
132 --------------------------------------------------
133
134 DECLARE -- (B)
135
136 PACKAGE PKG IS
137
138 SUBTYPE INTRANGE IS INTEGER RANGE 0..31;
139
140 TYPE RECTYPE (CONSTRAINT : INTRANGE := 15) IS PRIVATE;
141
142 PROCEDURE P (REC1 : IN RECTYPE; REC2 : IN OUT RECTYPE;
143 REC3 : OUT RECTYPE);
144
145 PRIVATE
146
147 TYPE RECTYPE (CONSTRAINT : INTRANGE := 15) IS
148 RECORD
149 INTFLD : INTRANGE;
150 STRFLD : STRING(1..CONSTRAINT);
151 END RECORD;
152 END PKG;
153
154 REC91, REC92, REC93 : PKG.RECTYPE(9);
155 REC_OOPS : PKG.RECTYPE(4);
156
157 PACKAGE BODY PKG IS
158
159 PROCEDURE P (REC1 : IN RECTYPE; REC2 : IN OUT RECTYPE;
160 REC3 : OUT RECTYPE) IS
161
162 PROCEDURE P1 (REC11 : IN RECTYPE;
163 REC12 : IN OUT RECTYPE;
164 REC13 : OUT RECTYPE) IS
165 BEGIN
166 IF (NOT REC11'CONSTRAINED) OR
167 (REC11.CONSTRAINT /= IDENT_INT(9)) THEN
168 FAILED ("CONSTRAINT ON PRIVATE " &
169 "TYPE IN PARAMETER " &
170 "NOT RECOGNIZED");
171 END IF;
172
173 BEGIN -- ASSIGNMENT TO IN OUT PARAMETER
174 REC12 := REC_OOPS;
175 FAILED ("CONSTRAINT ERROR NOT RAISED - " &
176 "B.1");
177 EXCEPTION
178 WHEN CONSTRAINT_ERROR =>
179 NULL;
180 WHEN OTHERS =>
181 FAILED ("WRONG EXCEPTION RAISED - " &
182 "B.1");
183 END;
184
185 BEGIN -- ASSIGNMENT TO OUT PARAMETER
186 REC13 := REC_OOPS;
187 FAILED ("CONSTRAINT_ERROR NOT RAISED - " &
188 "B.2");
189 EXCEPTION
190 WHEN CONSTRAINT_ERROR =>
191 NULL;
192 WHEN OTHERS =>
193 FAILED ("WRONG EXCEPTION RAISED - " &
194 "B.2");
195 END;
196 END P1;
197
198 BEGIN
199 P1 (REC1, REC2, REC3);
200 END P;
201
202 BEGIN
203
204 REC91 := (9, 9, "123456789");
205 REC92 := REC91;
206 REC93 := REC91;
207
208 REC_OOPS := (4, 4, "OOPS");
209
210 END PKG;
211
212 BEGIN -- (B)
213
214 PKG.P (REC91, REC92, REC93);
215
216 END; -- (B)
217
218 --------------------------------------------------
219
220 DECLARE -- (C)
221
222 PACKAGE PKG IS
223
224 SUBTYPE INTRANGE IS INTEGER RANGE 0..31;
225
226 TYPE RECTYPE (CONSTRAINT : INTRANGE := 15) IS
227 LIMITED PRIVATE;
228
229 PROCEDURE P (REC1 : IN RECTYPE; REC2 : IN OUT RECTYPE;
230 REC3 : OUT RECTYPE);
231
232 PRIVATE
233
234 TYPE RECTYPE (CONSTRAINT : INTRANGE := 15) IS
235 RECORD
236 INTFLD : INTRANGE;
237 STRFLD : STRING(1..CONSTRAINT);
238 END RECORD;
239 END PKG;
240
241 REC91,REC92,REC93 : PKG.RECTYPE(9);
242 REC_OOPS : PKG.RECTYPE(4);
243
244 PACKAGE BODY PKG IS
245
246 PROCEDURE P (REC1 : IN RECTYPE; REC2 : IN OUT RECTYPE;
247 REC3 : OUT RECTYPE) IS
248
249 PROCEDURE P1 (REC11 : IN RECTYPE;
250 REC12 : IN OUT RECTYPE;
251 REC13 : OUT RECTYPE) IS
252 BEGIN
253 IF (NOT REC11'CONSTRAINED) OR
254 (REC11.CONSTRAINT /= 9) THEN
255 FAILED ("CONSTRAINT ON LIMITED PRIVATE " &
256 "TYPE IN PARAMETER " &
257 "NOT RECOGNIZED");
258 END IF;
259
260 BEGIN -- ASSIGNMENT TO IN OUT PARAMETER
261 REC12 := REC_OOPS;
262 FAILED ("CONSTRAINT ERROR NOT RAISED - " &
263 "C.1");
264 EXCEPTION
265 WHEN CONSTRAINT_ERROR =>
266 NULL;
267 WHEN OTHERS =>
268 FAILED ("WRONG EXCEPTION RAISED - " &
269 "C.1");
270 END;
271
272 BEGIN -- ASSIGNMENT TO OUT PARAMETER
273 REC13 := REC_OOPS;
274 FAILED ("CONSTRAINT_ERROR NOT RAISED - " &
275 "C.2");
276 EXCEPTION
277 WHEN CONSTRAINT_ERROR =>
278 NULL;
279 WHEN OTHERS =>
280 FAILED ("WRONG EXCEPTION RAISED - " &
281 "C.2");
282 END;
283 END P1;
284
285 BEGIN
286 P1 (REC1, REC2, REC3);
287 END P;
288
289 BEGIN
290
291 REC91 := (9, 9, "123456789");
292 REC92 := REC91;
293 REC93 := REC91;
294
295 REC_OOPS := (4, 4, "OOPS");
296
297 END PKG;
298
299 BEGIN -- (C)
300
301 PKG.P (REC91, REC92, REC93);
302
303 END; -- (C)
304
305 --------------------------------------------------
306
307 RESULT;
308
309 END C64106C;