Mercurial > hg > CbC > CbC_gcc
comparison gcc/testsuite/ada/acats/tests/cc/cc3019c1.ada @ 111:04ced10e8804
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 -- CC3019C1.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 -- THIS IS GENERIC PACKAGE WHICH IS USED TO CHECK THE LEVEL OF | |
26 -- NESTED GENERICS SUPPORTED BY AN IMPLEMENTATION. IT IS USED | |
27 -- BY MAIN PROCEDURE CC3019C2M.ADA. | |
28 -- | |
29 -- HISTORY: | |
30 -- EDWARD V. BERARD, 31 AUGUST 1990 | |
31 | |
32 WITH CC3019C0_LIST_CLASS ; | |
33 | |
34 GENERIC | |
35 | |
36 TYPE ELEMENT IS LIMITED PRIVATE ; | |
37 | |
38 WITH PROCEDURE ASSIGN (SOURCE : IN OUT ELEMENT ; | |
39 DESTINATION : IN OUT ELEMENT) ; | |
40 | |
41 WITH FUNCTION "=" (LEFT : IN ELEMENT ; | |
42 RIGHT : IN ELEMENT) RETURN BOOLEAN ; | |
43 | |
44 PACKAGE CC3019C1_NESTED_GENERICS IS | |
45 | |
46 TYPE NESTED_GENERICS_TYPE IS LIMITED PRIVATE ; | |
47 | |
48 PROCEDURE COPY (SOURCE : IN OUT NESTED_GENERICS_TYPE ; | |
49 DESTINATION : IN OUT NESTED_GENERICS_TYPE) ; | |
50 | |
51 PROCEDURE SET_ELEMENT | |
52 (FOR_THIS_NGT_OBJECT : IN OUT NESTED_GENERICS_TYPE ; | |
53 TO_THIS_ELEMENT : IN OUT ELEMENT) ; | |
54 | |
55 PROCEDURE SET_NUMBER | |
56 (FOR_THIS_NGT_OBJECT : IN OUT NESTED_GENERICS_TYPE ; | |
57 TO_THIS_NUMBER : IN NATURAL) ; | |
58 | |
59 FUNCTION "=" (LEFT : IN NESTED_GENERICS_TYPE ; | |
60 RIGHT : IN NESTED_GENERICS_TYPE) RETURN BOOLEAN ; | |
61 | |
62 FUNCTION ELEMENT_OF (THIS_NGT_OBJECT : IN NESTED_GENERICS_TYPE) | |
63 RETURN ELEMENT ; | |
64 | |
65 FUNCTION NUMBER_OF (THIS_NGT_OBJECT : IN NESTED_GENERICS_TYPE) | |
66 RETURN NATURAL ; | |
67 | |
68 GENERIC | |
69 | |
70 TYPE ELEMENT IS LIMITED PRIVATE ; | |
71 | |
72 WITH PROCEDURE ASSIGN (SOURCE : IN OUT ELEMENT ; | |
73 DESTINATION : IN OUT ELEMENT) ; | |
74 | |
75 PACKAGE GENERIC_TASK IS | |
76 | |
77 TASK TYPE PROTECTED_AREA IS | |
78 | |
79 ENTRY STORE (ITEM : IN OUT ELEMENT) ; | |
80 ENTRY GET (ITEM : IN OUT ELEMENT) ; | |
81 | |
82 END PROTECTED_AREA ; | |
83 | |
84 END GENERIC_TASK ; | |
85 | |
86 GENERIC | |
87 | |
88 TYPE ELEMENT IS LIMITED PRIVATE ; | |
89 | |
90 WITH PROCEDURE ASSIGN (SOURCE : IN OUT ELEMENT ; | |
91 DESTINATION : IN OUT ELEMENT) ; | |
92 | |
93 WITH FUNCTION "=" (LEFT : IN ELEMENT ; | |
94 RIGHT : IN ELEMENT) RETURN BOOLEAN ; | |
95 | |
96 PACKAGE STACK_CLASS IS | |
97 | |
98 TYPE STACK IS LIMITED PRIVATE ; | |
99 | |
100 OVERFLOW : EXCEPTION ; | |
101 UNDERFLOW : EXCEPTION ; | |
102 | |
103 PROCEDURE PUSH (THIS_ELEMENT : IN OUT ELEMENT ; | |
104 ON_TO_THIS_STACK : IN OUT STACK) ; | |
105 | |
106 PROCEDURE POP (THIS_ELEMENT : IN OUT ELEMENT ; | |
107 OFF_THIS_STACK : IN OUT STACK) ; | |
108 | |
109 PROCEDURE COPY (THIS_STACK : IN OUT STACK ; | |
110 TO_THIS_STACK : IN OUT STACK) ; | |
111 | |
112 PROCEDURE CLEAR (THIS_STACK : IN OUT STACK) ; | |
113 | |
114 GENERIC | |
115 | |
116 WITH PROCEDURE PROCESS (THIS_ELEMENT : IN ELEMENT ; | |
117 CONTINUE : OUT BOOLEAN) ; | |
118 | |
119 PROCEDURE ITERATE (OVER_THIS_STACK : IN STACK) ; | |
120 | |
121 FUNCTION NUMBER_OF_ELEMENTS (ON_THIS_STACK : IN STACK) | |
122 RETURN NATURAL ; | |
123 | |
124 FUNCTION "=" (LEFT : IN STACK ; | |
125 RIGHT : IN STACK) RETURN BOOLEAN ; | |
126 | |
127 PRIVATE | |
128 | |
129 PACKAGE NEW_LIST_CLASS IS NEW | |
130 CC3019C0_LIST_CLASS (ELEMENT => ELEMENT, | |
131 ASSIGN => ASSIGN, | |
132 "=" => "=") ; | |
133 | |
134 TYPE STACK IS NEW NEW_LIST_CLASS.LIST ; | |
135 | |
136 END STACK_CLASS ; | |
137 | |
138 PRIVATE | |
139 | |
140 TYPE NESTED_GENERICS_TYPE IS RECORD | |
141 FIRST : ELEMENT ; | |
142 SECOND : NATURAL ; | |
143 END RECORD ; | |
144 | |
145 END CC3019C1_NESTED_GENERICS ; | |
146 | |
147 PACKAGE BODY CC3019C1_NESTED_GENERICS IS | |
148 | |
149 PROCEDURE COPY (SOURCE : IN OUT NESTED_GENERICS_TYPE ; | |
150 DESTINATION : IN OUT NESTED_GENERICS_TYPE) IS | |
151 | |
152 BEGIN -- COPY | |
153 | |
154 ASSIGN (SOURCE => SOURCE.FIRST, | |
155 DESTINATION => DESTINATION.FIRST) ; | |
156 | |
157 DESTINATION.SECOND := SOURCE.SECOND ; | |
158 | |
159 END COPY ; | |
160 | |
161 PROCEDURE SET_ELEMENT | |
162 (FOR_THIS_NGT_OBJECT : IN OUT NESTED_GENERICS_TYPE ; | |
163 TO_THIS_ELEMENT : IN OUT ELEMENT) IS | |
164 | |
165 BEGIN -- SET_ELEMENT | |
166 | |
167 ASSIGN (SOURCE => TO_THIS_ELEMENT, | |
168 DESTINATION => FOR_THIS_NGT_OBJECT.FIRST) ; | |
169 | |
170 END SET_ELEMENT ; | |
171 | |
172 PROCEDURE SET_NUMBER | |
173 (FOR_THIS_NGT_OBJECT : IN OUT NESTED_GENERICS_TYPE ; | |
174 TO_THIS_NUMBER : IN NATURAL) IS | |
175 | |
176 BEGIN -- SET_NUMBER | |
177 | |
178 FOR_THIS_NGT_OBJECT.SECOND := TO_THIS_NUMBER ; | |
179 | |
180 END SET_NUMBER ; | |
181 | |
182 FUNCTION "=" (LEFT : IN NESTED_GENERICS_TYPE ; | |
183 RIGHT : IN NESTED_GENERICS_TYPE) RETURN BOOLEAN IS | |
184 | |
185 BEGIN -- "=" | |
186 | |
187 IF (LEFT.FIRST = RIGHT.FIRST) AND | |
188 (LEFT.SECOND = RIGHT.SECOND) THEN | |
189 RETURN TRUE ; | |
190 ELSE | |
191 RETURN FALSE ; | |
192 END IF ; | |
193 | |
194 END "=" ; | |
195 | |
196 FUNCTION ELEMENT_OF (THIS_NGT_OBJECT : IN NESTED_GENERICS_TYPE) | |
197 RETURN ELEMENT IS | |
198 | |
199 BEGIN -- ELEMENT_OF | |
200 | |
201 RETURN THIS_NGT_OBJECT.FIRST ; | |
202 | |
203 END ELEMENT_OF ; | |
204 | |
205 FUNCTION NUMBER_OF (THIS_NGT_OBJECT : IN NESTED_GENERICS_TYPE) | |
206 RETURN NATURAL IS | |
207 | |
208 BEGIN -- NUMBER_OF | |
209 | |
210 RETURN THIS_NGT_OBJECT.SECOND ; | |
211 | |
212 END NUMBER_OF ; | |
213 | |
214 PACKAGE BODY GENERIC_TASK IS | |
215 | |
216 TASK BODY PROTECTED_AREA IS | |
217 | |
218 LOCAL_STORE : ELEMENT ; | |
219 | |
220 BEGIN -- PROTECTED_AREA | |
221 | |
222 LOOP | |
223 SELECT | |
224 ACCEPT STORE (ITEM : IN OUT ELEMENT) DO | |
225 ASSIGN (SOURCE => ITEM, | |
226 DESTINATION => LOCAL_STORE) ; | |
227 END STORE ; | |
228 OR | |
229 ACCEPT GET (ITEM : IN OUT ELEMENT) DO | |
230 ASSIGN (SOURCE => LOCAL_STORE, | |
231 DESTINATION => ITEM) ; | |
232 END GET ; | |
233 OR | |
234 TERMINATE ; | |
235 END SELECT ; | |
236 END LOOP ; | |
237 | |
238 END PROTECTED_AREA ; | |
239 | |
240 END GENERIC_TASK ; | |
241 | |
242 PACKAGE BODY STACK_CLASS IS | |
243 | |
244 PROCEDURE PUSH (THIS_ELEMENT : IN OUT ELEMENT ; | |
245 ON_TO_THIS_STACK : IN OUT STACK) IS | |
246 | |
247 BEGIN -- PUSH | |
248 | |
249 NEW_LIST_CLASS.ADD ( | |
250 THIS_ELEMENT => THIS_ELEMENT, | |
251 TO_THIS_LIST => | |
252 NEW_LIST_CLASS.LIST (ON_TO_THIS_STACK)) ; | |
253 | |
254 EXCEPTION | |
255 | |
256 WHEN NEW_LIST_CLASS.OVERFLOW => RAISE OVERFLOW ; | |
257 | |
258 END PUSH ; | |
259 | |
260 PROCEDURE POP (THIS_ELEMENT : IN OUT ELEMENT ; | |
261 OFF_THIS_STACK : IN OUT STACK) IS | |
262 | |
263 BEGIN -- POP | |
264 | |
265 NEW_LIST_CLASS.DELETE ( | |
266 THIS_ELEMENT => THIS_ELEMENT, | |
267 FROM_THIS_LIST => | |
268 NEW_LIST_CLASS.LIST (OFF_THIS_STACK)) ; | |
269 | |
270 EXCEPTION | |
271 | |
272 WHEN NEW_LIST_CLASS.UNDERFLOW => RAISE UNDERFLOW ; | |
273 | |
274 END POP ; | |
275 | |
276 PROCEDURE COPY (THIS_STACK : IN OUT STACK ; | |
277 TO_THIS_STACK : IN OUT STACK) IS | |
278 | |
279 BEGIN -- COPY | |
280 | |
281 NEW_LIST_CLASS.COPY ( | |
282 THIS_LIST => NEW_LIST_CLASS.LIST (THIS_STACK), | |
283 TO_THIS_LIST => | |
284 NEW_LIST_CLASS.LIST (TO_THIS_STACK)) ; | |
285 | |
286 END COPY ; | |
287 | |
288 PROCEDURE CLEAR (THIS_STACK : IN OUT STACK) IS | |
289 | |
290 BEGIN -- CLEAR | |
291 | |
292 NEW_LIST_CLASS.CLEAR (NEW_LIST_CLASS.LIST (THIS_STACK)) ; | |
293 | |
294 END CLEAR ; | |
295 | |
296 PROCEDURE ITERATE (OVER_THIS_STACK : IN STACK) IS | |
297 | |
298 PROCEDURE STACK_ITERATE IS NEW NEW_LIST_CLASS.ITERATE | |
299 (PROCESS => PROCESS) ; | |
300 | |
301 BEGIN -- ITERATE | |
302 | |
303 STACK_ITERATE (NEW_LIST_CLASS.LIST (OVER_THIS_STACK)) ; | |
304 | |
305 END ITERATE ; | |
306 | |
307 FUNCTION NUMBER_OF_ELEMENTS (ON_THIS_STACK : IN STACK) | |
308 RETURN NATURAL IS | |
309 | |
310 BEGIN -- NUMBER_OF_ELEMENTS | |
311 | |
312 RETURN NEW_LIST_CLASS.NUMBER_OF_ELEMENTS | |
313 (IN_THIS_LIST => | |
314 NEW_LIST_CLASS.LIST (ON_THIS_STACK)) ; | |
315 | |
316 END NUMBER_OF_ELEMENTS ; | |
317 | |
318 FUNCTION "=" (LEFT : IN STACK ; | |
319 RIGHT : IN STACK) RETURN BOOLEAN IS | |
320 | |
321 BEGIN -- "=" | |
322 | |
323 RETURN NEW_LIST_CLASS."=" ( | |
324 LEFT => NEW_LIST_CLASS.LIST (LEFT), | |
325 RIGHT => NEW_LIST_CLASS.LIST (RIGHT)) ; | |
326 | |
327 END "=" ; | |
328 | |
329 END STACK_CLASS ; | |
330 | |
331 END CC3019C1_NESTED_GENERICS ; |