Mercurial > hg > CbC > CbC_gcc

comparison gcc/testsuite/ada/acats/tests/c6/c64005c.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 -- C64005C.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 NESTED SUBPROGRAMS CAN BE CALLED RECURSIVELY AND THAT
26 -- NON-LOCAL VARIABLES AND FORMAL PARAMETERS ARE PROPERLY ACCESSED FROM
27 -- WITHIN RECURSIVE INVOCATIONS. THIS TEST CHECKS THAT EVERY DISPLAY OR
28 -- STATIC CHAIN LEVEL CAN BE ACCESSED.
29
30 -- THIS TEST USES 3 LEVELS OF NESTED RECURSIVE PROCEDURES.
31
32 -- JRK 7/26/84
33
34 WITH REPORT; USE REPORT;
35
36 PROCEDURE C64005C IS
37
38 SUBTYPE LEVEL IS CHARACTER RANGE 'A' .. 'C';
39 SUBTYPE CALL IS CHARACTER RANGE '1' .. '3';
40
41 MAX_LEV : CONSTANT := LEVEL'POS (LEVEL'LAST) -
42 LEVEL'POS (LEVEL'FIRST) + 1;
43 T_LEN : CONSTANT := 2 * (1 + 3 * (MAX_LEV +
44 MAX_LEV*(MAX_LEV+1)/2*2)) + 1;
45 G_LEN : CONSTANT := 2 + 4 * MAX_LEV;
46
47 TYPE TRACE IS
48 RECORD
49 E : NATURAL := 0;
50 S : STRING (1 .. T_LEN);
51 END RECORD;
52
53 V : CHARACTER := IDENT_CHAR ('<');
54 L : CHARACTER := IDENT_CHAR ('>');
55 T : TRACE;
56 G : STRING (1 .. G_LEN);
57
58 PROCEDURE C64005CA (L : LEVEL; C : CALL; T : IN OUT TRACE) IS
59
60 V : STRING (1..2);
61
62 M : CONSTANT NATURAL := LEVEL'POS (L) -
63 LEVEL'POS (LEVEL'FIRST) + 1;
64 N : CONSTANT NATURAL := 2 * M + 1;
65
66 PROCEDURE C64005CB (L : LEVEL; C : CALL; T : IN OUT TRACE) IS
67
68 V : STRING (1..2);
69
70 M : CONSTANT NATURAL := LEVEL'POS (L) -
71 LEVEL'POS (LEVEL'FIRST) + 1;
72 N : CONSTANT NATURAL := 2 * M + 1;
73
74 PROCEDURE C64005CC (L : LEVEL; C : CALL;
75 T : IN OUT TRACE) IS
76
77 V : STRING (1..2);
78
79 M : CONSTANT NATURAL := LEVEL'POS (L) -
80 LEVEL'POS (LEVEL'FIRST) + 1;
81 N : CONSTANT NATURAL := 2 * M + 1;
82
83 BEGIN
84
85 V (1) := IDENT_CHAR (ASCII.LC_C);
86 V (2) := C;
87
88 -- APPEND ALL V TO T.
89 T.S (T.E+1 .. T.E+N) := C64005C.V & C64005CA.V &
90 C64005CB.V & C64005CC.V;
91 T.E := T.E + N;
92
93 CASE C IS
94
95 WHEN '1' =>
96 C64005CA (IDENT_CHAR(LEVEL'FIRST),
97 IDENT_CHAR('2'), T);
98
99 WHEN '2' =>
100 C64005CC (L, IDENT_CHAR('3'), T);
101
102 WHEN '3' =>
103 -- APPEND MID-POINT SYMBOL TO T.
104 T.S (T.E+1) := IDENT_CHAR ('=');
105 T.E := T.E + 1;
106
107 -- G := CATENATE ALL V, L, C;
108 G := C64005C.V & C64005C.L &
109 C64005CA.V & C64005CA.L & C64005CA.C &
110 C64005CB.V & C64005CB.L & C64005CB.C &
111 C64005CC.V & C64005CC.L & C64005CC.C;
112 END CASE;
113
114 -- APPEND ALL L AND C TO T IN REVERSE ORDER.
115 T.S (T.E+1 .. T.E+N) := C64005CC.L & C64005CC.C &
116 C64005CB.L & C64005CB.C &
117 C64005CA.L & C64005CA.C &
118 C64005C.L;
119 T.E := T.E + N;
120
121 END C64005CC;
122
123 BEGIN
124
125 V (1) := IDENT_CHAR (ASCII.LC_B);
126 V (2) := C;
127
128 -- APPEND ALL V TO T.
129 T.S (T.E+1 .. T.E+N) := C64005C.V & C64005CA.V &
130 C64005CB.V;
131 T.E := T.E + N;
132
133 CASE C IS
134
135 WHEN '1' =>
136 C64005CC (LEVEL'SUCC(L), IDENT_CHAR('1'), T);
137
138 WHEN '2' =>
139 C64005CB (L, IDENT_CHAR('3'), T);
140
141 WHEN '3' =>
142 C64005CC (LEVEL'SUCC(L), IDENT_CHAR('2'), T);
143 END CASE;
144
145 -- APPEND ALL L AND C TO T IN REVERSE ORDER.
146 T.S (T.E+1 .. T.E+N) := C64005CB.L & C64005CB.C &
147 C64005CA.L & C64005CA.C &
148 C64005C.L;
149 T.E := T.E + N;
150
151 END C64005CB;
152
153 BEGIN
154
155 V (1) := IDENT_CHAR (ASCII.LC_A);
156 V (2) := C;
157
158 -- APPEND ALL V TO T.
159 T.S (T.E+1 .. T.E+N) := C64005C.V & C64005CA.V;
160 T.E := T.E + N;
161
162 CASE C IS
163
164 WHEN '1' =>
165 C64005CB (LEVEL'SUCC(L), IDENT_CHAR('1'), T);
166
167 WHEN '2' =>
168 C64005CA (L, IDENT_CHAR('3'), T);
169
170 WHEN '3' =>
171 C64005CB (LEVEL'SUCC(L), IDENT_CHAR('2'), T);
172 END CASE;
173
174 -- APPEND ALL L AND C TO T IN REVERSE ORDER.
175 T.S (T.E+1 .. T.E+N) := C64005CA.L & C64005CA.C & C64005C.L;
176 T.E := T.E + N;
177
178 END C64005CA;
179
180 BEGIN
181 TEST ("C64005C", "CHECK THAT NON-LOCAL VARIABLES AND FORMAL " &
182 "PARAMETERS AT ALL LEVELS OF NESTED " &
183 "RECURSIVE PROCEDURES ARE ACCESSIBLE");
184
185 -- APPEND V TO T.
186 T.S (T.E+1) := V;
187 T.E := T.E + 1;
188
189 C64005CA (IDENT_CHAR(LEVEL'FIRST), IDENT_CHAR('1'), T);
190
191 -- APPEND L TO T.
192 T.S (T.E+1) := L;
193 T.E := T.E + 1;
194
195 COMMENT ("FINAL CALL TRACE LENGTH IS: " & INTEGER'IMAGE(T.E));
196 COMMENT ("FINAL CALL TRACE IS: " & T.S(1..T.E));
197 COMMENT ("GLOBAL SNAPSHOT IS: " & G);
198
199 -- CHECK THAT T AND G ARE CORRECT BY COMPUTING THEM ITERATIVELY.
200
201 DECLARE
202 SUBTYPE LC_LEVEL IS CHARACTER RANGE ASCII.LC_A ..
203 CHARACTER'VAL (CHARACTER'POS(ASCII.LC_A) + MAX_LEV - 1);
204
205 CT : TRACE;
206 CG : STRING (1 .. G_LEN);
207 BEGIN
208 COMMENT ("CORRECT FINAL CALL TRACE LENGTH IS: " &
209 INTEGER'IMAGE(T_LEN));
210
211 IF T.E /= IDENT_INT (T_LEN) THEN
212 FAILED ("WRONG FINAL CALL TRACE LENGTH");
213
214 ELSE CT.S (CT.E+1) := '<';
215 CT.E := CT.E + 1;
216
217 FOR I IN LC_LEVEL LOOP
218 CT.S (CT.E+1) := '<';
219 CT.E := CT.E + 1;
220
221 FOR J IN LC_LEVEL'FIRST .. I LOOP
222 CT.S (CT.E+1) := J;
223 CT.S (CT.E+2) := '1';
224 CT.E := CT.E + 2;
225 END LOOP;
226 END LOOP;
227
228 FOR I IN LC_LEVEL LOOP
229 CT.S (CT.E+1) := '<';
230 CT.E := CT.E + 1;
231
232 FOR J IN LC_LEVEL'FIRST .. LC_LEVEL'PRED(I) LOOP
233 CT.S (CT.E+1) := J;
234 CT.S (CT.E+2) := '3';
235 CT.E := CT.E + 2;
236 END LOOP;
237
238 CT.S (CT.E+1) := I;
239 CT.S (CT.E+2) := '2';
240 CT.E := CT.E + 2;
241
242 CT.S (CT.E+1) := '<';
243 CT.E := CT.E + 1;
244
245 FOR J IN LC_LEVEL'FIRST .. I LOOP
246 CT.S (CT.E+1) := J;
247 CT.S (CT.E+2) := '3';
248 CT.E := CT.E + 2;
249 END LOOP;
250 END LOOP;
251
252 CT.S (CT.E+1) := '=';
253 CT.E := CT.E + 1;
254
255 FOR I IN REVERSE LEVEL LOOP
256 FOR J IN REVERSE LEVEL'FIRST .. I LOOP
257 CT.S (CT.E+1) := J;
258 CT.S (CT.E+2) := '3';
259 CT.E := CT.E + 2;
260 END LOOP;
261
262 CT.S (CT.E+1) := '>';
263 CT.E := CT.E + 1;
264
265 CT.S (CT.E+1) := I;
266 CT.S (CT.E+2) := '2';
267 CT.E := CT.E + 2;
268
269 FOR J IN REVERSE LEVEL'FIRST .. LEVEL'PRED(I) LOOP
270 CT.S (CT.E+1) := J;
271 CT.S (CT.E+2) := '3';
272 CT.E := CT.E + 2;
273 END LOOP;
274
275 CT.S (CT.E+1) := '>';
276 CT.E := CT.E + 1;
277 END LOOP;
278
279 FOR I IN REVERSE LEVEL LOOP
280 FOR J IN REVERSE LEVEL'FIRST .. I LOOP
281 CT.S (CT.E+1) := J;
282 CT.S (CT.E+2) := '1';
283 CT.E := CT.E + 2;
284 END LOOP;
285
286 CT.S (CT.E+1) := '>';
287 CT.E := CT.E + 1;
288 END LOOP;
289
290 CT.S (CT.E+1) := '>';
291 CT.E := CT.E + 1;
292
293 IF CT.E /= IDENT_INT (T_LEN) THEN
294 FAILED ("WRONG ITERATIVE TRACE LENGTH");
295
296 ELSE COMMENT ("CORRECT FINAL CALL TRACE IS: " & CT.S);
297
298 IF T.S /= CT.S THEN
299 FAILED ("WRONG FINAL CALL TRACE");
300 END IF;
301 END IF;
302 END IF;
303
304 DECLARE
305 E : NATURAL := 0;
306 BEGIN
307 CG (1..2) := "<>";
308 E := E + 2;
309
310 FOR I IN LEVEL LOOP
311 CG (E+1) := LC_LEVEL'VAL (LEVEL'POS(I) -
312 LEVEL'POS(LEVEL'FIRST) +
313 LC_LEVEL'POS
314 (LC_LEVEL'FIRST));
315 CG (E+2) := '3';
316 CG (E+3) := I;
317 CG (E+4) := '3';
318 E := E + 4;
319 END LOOP;
320
321 COMMENT ("CORRECT GLOBAL SNAPSHOT IS: " & CG);
322
323 IF G /= CG THEN
324 FAILED ("WRONG GLOBAL SNAPSHOT");
325 END IF;
326 END;
327 END;
328
329 RESULT;
330 END C64005C;