Mercurial > hg > CbC > CbC_gcc

comparison gcc/testsuite/ada/acats/tests/c3/c34005o.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 -- C34005O.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 -- OBJECTIVE:
26 -- FOR DERIVED MULTI-DIMENSIONAL ARRAY TYPES WHOSE COMPONENT TYPE
27 -- IS A NON-LIMITED TYPE:
28 -- CHECK THAT ALL VALUES OF THE PARENT (BASE) TYPE ARE PRESENT FOR
29 -- THE DERIVED (BASE) TYPE WHEN THE DERIVED TYPE DEFINITION IS
30 -- CONSTRAINED.
31 -- CHECK THAT ANY CONSTRAINT IMPOSED ON THE PARENT SUBTYPE IS ALSO
32 -- IMPOSED ON THE DERIVED SUBTYPE.
33
34 -- HISTORY:
35 -- JRK 9/17/86 CREATED ORIGINAL TEST.
36
37 WITH REPORT; USE REPORT;
38
39 PROCEDURE C34005O IS
40
41 SUBTYPE COMPONENT IS INTEGER;
42
43 PACKAGE PKG IS
44
45 FIRST : CONSTANT := 0;
46 LAST : CONSTANT := 10;
47
48 SUBTYPE INDEX IS INTEGER RANGE FIRST .. LAST;
49
50 TYPE PARENT IS ARRAY (INDEX RANGE <>, INDEX RANGE <>) OF
51 COMPONENT;
52
53 FUNCTION CREATE ( F1, L1 : INDEX;
54 F2, L2 : INDEX;
55 C : COMPONENT;
56 DUMMY : PARENT -- TO RESOLVE OVERLOADING.
57 ) RETURN PARENT;
58
59 END PKG;
60
61 USE PKG;
62
63 TYPE T IS NEW PARENT (IDENT_INT (4) .. IDENT_INT (5),
64 IDENT_INT (6) .. IDENT_INT (8));
65
66 SUBTYPE SUBPARENT IS PARENT (4 .. 5, 6 .. 8);
67
68 TYPE S IS NEW SUBPARENT;
69
70 X : T := (OTHERS => (OTHERS => 2));
71 Y : S := (OTHERS => (OTHERS => 2));
72
73 PACKAGE BODY PKG IS
74
75 FUNCTION CREATE
76 ( F1, L1 : INDEX;
77 F2, L2 : INDEX;
78 C : COMPONENT;
79 DUMMY : PARENT
80 ) RETURN PARENT
81 IS
82 A : PARENT (F1 .. L1, F2 .. L2);
83 B : COMPONENT := C;
84 BEGIN
85 FOR I IN F1 .. L1 LOOP
86 FOR J IN F2 .. L2 LOOP
87 A (I, J) := B;
88 B := B + 1;
89 END LOOP;
90 END LOOP;
91 RETURN A;
92 END CREATE;
93
94 END PKG;
95
96 BEGIN
97 TEST ("C34005O", "CHECK THAT ALL VALUES OF THE PARENT (BASE) " &
98 "TYPE ARE PRESENT FOR THE DERIVED (BASE) TYPE " &
99 "WHEN THE DERIVED TYPE DEFINITION IS " &
100 "CONSTRAINED. ALSO CHECK THAT ANY CONSTRAINT " &
101 "IMPOSED ON THE PARENT SUBTYPE IS ALSO IMPOSED " &
102 "ON THE DERIVED SUBTYPE. CHECK FOR DERIVED " &
103 "MULTI-DIMENSIONAL ARRAY TYPES WHOSE COMPONENT " &
104 "TYPE IS A NON-LIMITED TYPE");
105
106 -- CHECK THAT BASE TYPE VALUES NOT IN THE SUBTYPE ARE PRESENT.
107
108 BEGIN
109 IF CREATE (6, 9, 2, 3, 1, X) /=
110 ((1, 2), (3, 4), (5, 6), (7, 8)) OR
111 CREATE (6, 9, 2, 3, 1, Y) /=
112 ((1, 2), (3, 4), (5, 6), (7, 8)) THEN
113 FAILED ("CAN'T CREATE BASE TYPE VALUES OUTSIDE THE " &
114 "SUBTYPE");
115 END IF;
116 EXCEPTION
117 WHEN CONSTRAINT_ERROR =>
118 FAILED ("CALL TO CREATE RAISED CONSTRAINT_ERROR");
119 WHEN OTHERS =>
120 FAILED ("CALL TO CREATE RAISED EXCEPTION");
121 END;
122
123 IF ((1, 2), (3, 4), (5, 6), (7, 8)) IN T OR
124 ((1, 2), (3, 4), (5, 6), (7, 8)) IN S THEN
125 FAILED ("INCORRECT ""IN""");
126 END IF;
127
128 -- CHECK THE DERIVED SUBTYPE CONSTRAINT.
129
130 IF T'FIRST /= 4 OR T'LAST /= 5 OR
131 S'FIRST /= 4 OR S'LAST /= 5 OR
132 T'FIRST (2) /= 6 OR T'LAST (2) /= 8 OR
133 S'FIRST (2) /= 6 OR S'LAST (2) /= 8 THEN
134 FAILED ("INCORRECT 'FIRST OR 'LAST");
135 END IF;
136
137 BEGIN
138 X := ((1, 2, 3), (4, 5, 6));
139 Y := ((1, 2, 3), (4, 5, 6));
140 IF PARENT (X) /= PARENT (Y) THEN -- USE X AND Y.
141 FAILED ("INCORRECT CONVERSION TO PARENT");
142 END IF;
143 EXCEPTION
144 WHEN OTHERS =>
145 FAILED ("EXCEPTION RAISED BY OK ASSIGNMENT");
146 END;
147
148 BEGIN
149 X := (4 => (6 .. 8 => 0));
150 FAILED ("CONSTRAINT_ERROR NOT RAISED -- " &
151 "X := (4 => (6 .. 8 => 0))");
152 IF X = (4 => (6 .. 8 => 0)) THEN -- USE X.
153 COMMENT ("X ALTERED -- " &
154 "X := (4 => (6 .. 8 => 0))");
155 END IF;
156 EXCEPTION
157 WHEN CONSTRAINT_ERROR =>
158 NULL;
159 WHEN OTHERS =>
160 FAILED ("WRONG EXCEPTION RAISED -- " &
161 "X := (4 => (6 .. 8 => 0))");
162 END;
163
164 BEGIN
165 X := (4 .. 6 => (6 .. 8 => 0));
166 FAILED ("CONSTRAINT_ERROR NOT RAISED -- " &
167 "X := (4 .. 6 => (6 .. 8 => 0))");
168 IF X = (4 .. 6 => (6 .. 8 => 0)) THEN -- USE X.
169 COMMENT ("X ALTERED -- " &
170 "X := (4 .. 6 => (6 .. 8 => 0))");
171 END IF;
172 EXCEPTION
173 WHEN CONSTRAINT_ERROR =>
174 NULL;
175 WHEN OTHERS =>
176 FAILED ("WRONG EXCEPTION RAISED -- " &
177 "X := (4 .. 6 => (6 .. 8 => 0))");
178 END;
179
180 BEGIN
181 X := (4 .. 5 => (6 .. 7 => 0));
182 FAILED ("CONSTRAINT_ERROR NOT RAISED -- " &
183 "X := (4 .. 5 => (6 .. 7 => 0))");
184 IF X = (4 .. 5 => (6 .. 7 => 0)) THEN -- USE X.
185 COMMENT ("X ALTERED -- " &
186 "X := (4 .. 5 => (6 .. 7 => 0))");
187 END IF;
188 EXCEPTION
189 WHEN CONSTRAINT_ERROR =>
190 NULL;
191 WHEN OTHERS =>
192 FAILED ("WRONG EXCEPTION RAISED -- " &
193 "X := (4 .. 5 => (6 .. 7 => 0))");
194 END;
195
196 BEGIN
197 X := (4 .. 5 => (6 .. 9 => 0));
198 FAILED ("CONSTRAINT_ERROR NOT RAISED -- " &
199 "X := (4 .. 5 => (6 .. 9 => 0))");
200 IF X = (4 .. 5 => (6 .. 9 => 0)) THEN -- USE X.
201 COMMENT ("X ALTERED -- " &
202 "X := (4 .. 5 => (6 .. 9 => 0))");
203 END IF;
204 EXCEPTION
205 WHEN CONSTRAINT_ERROR =>
206 NULL;
207 WHEN OTHERS =>
208 FAILED ("WRONG EXCEPTION RAISED -- " &
209 "X := (4 .. 5 => (6 .. 9 => 0))");
210 END;
211
212 BEGIN
213 Y := (4 => (6 .. 8 => 0));
214 FAILED ("CONSTRAINT_ERROR NOT RAISED -- " &
215 "Y := (4 => (6 .. 8 => 0))");
216 IF Y = (4 => (6 .. 8 => 0)) THEN -- USE Y.
217 COMMENT ("Y ALTERED -- " &
218 "Y := (4 => (6 .. 8 => 0))");
219 END IF;
220 EXCEPTION
221 WHEN CONSTRAINT_ERROR =>
222 NULL;
223 WHEN OTHERS =>
224 FAILED ("WRONG EXCEPTION RAISED -- " &
225 "Y := (4 => (6 .. 8 => 0))");
226 END;
227
228 BEGIN
229 Y := (4 .. 6 => (6 .. 8 => 0));
230 FAILED ("CONSTRAINT_ERROR NOT RAISED -- " &
231 "Y := (4 .. 6 => (6 .. 8 => 0))");
232 IF Y = (4 .. 6 => (6 .. 8 => 0)) THEN -- USE Y.
233 COMMENT ("Y ALTERED -- " &
234 "Y := (4 .. 6 => (6 .. 8 => 0))");
235 END IF;
236 EXCEPTION
237 WHEN CONSTRAINT_ERROR =>
238 NULL;
239 WHEN OTHERS =>
240 FAILED ("WRONG EXCEPTION RAISED -- " &
241 "Y := (4 .. 6 => (6 .. 8 => 0))");
242 END;
243
244 BEGIN
245 Y := (4 .. 5 => (6 .. 7 => 0));
246 FAILED ("CONSTRAINT_ERROR NOT RAISED -- " &
247 "Y := (4 .. 5 => (6 .. 7 => 0))");
248 IF Y = (4 .. 5 => (6 .. 7 => 0)) THEN -- USE Y.
249 COMMENT ("Y ALTERED -- " &
250 "Y := (4 .. 5 => (6 .. 7 => 0))");
251 END IF;
252 EXCEPTION
253 WHEN CONSTRAINT_ERROR =>
254 NULL;
255 WHEN OTHERS =>
256 FAILED ("WRONG EXCEPTION RAISED -- " &
257 "Y := (4 .. 5 => (6 .. 7 => 0))");
258 END;
259
260 BEGIN
261 Y := (4 .. 5 => (6 .. 9 => 0));
262 FAILED ("CONSTRAINT_ERROR NOT RAISED -- " &
263 "Y := (4 .. 5 => (6 .. 9 => 0))");
264 IF Y = (4 .. 5 => (6 .. 9 => 0)) THEN -- USE Y.
265 COMMENT ("Y ALTERED -- " &
266 "Y := (4 .. 5 => (6 .. 9 => 0))");
267 END IF;
268 EXCEPTION
269 WHEN CONSTRAINT_ERROR =>
270 NULL;
271 WHEN OTHERS =>
272 FAILED ("WRONG EXCEPTION RAISED -- " &
273 "Y := (4 .. 5 => (6 .. 9 => 0))");
274 END;
275
276 RESULT;
277 END C34005O;