Mercurial > hg > CbC > CbC_gcc
comparison gcc/testsuite/ada/acats/tests/c9/c93005d.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 -- C93005D.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 IF AN EXCEPTION IS RAISED IN A DECLARATIVE PART OR PACKAGE | |
26 -- SPECIFICATION, A TASK DECLARED IN THE SAME DECLARATIVE PART BECOMES | |
27 -- COMPLETED BEFORE IT HAS BEEN ACTIVATED; ANY TASKS AWAITING A | |
28 -- RENDEZVOUS WITH THE COMPLETED RECEIVE TASKING_ERROR. | |
29 | |
30 -- CASE 2: TASKS IN DECLARATIVE PART OF A BLOCK AND PACKAGE | |
31 -- SPECIFICATION. THE TASKS DEPEND ON THE DECLARATIVE PART. | |
32 -- OTHER TASKS HAVE BEEN QUEUED ON THE TASKS' ENTRIES. | |
33 | |
34 -- RAC 19-MAR-1985 | |
35 -- JBG 06/03/85 | |
36 -- EG 10/30/85 ELIMINATE THE USE OF NUMERIC_ERROR IN TEST. | |
37 -- PWN 01/31/95 REMOVED PRAGMA PRIORITY FOR ADA 9X. | |
38 -- ADDED PROCEDURE TO KEEP PACKAGE BODIES LEGAL. | |
39 | |
40 with Impdef; | |
41 | |
42 WITH REPORT; USE REPORT; | |
43 WITH SYSTEM; USE SYSTEM; | |
44 PRAGMA ELABORATE (REPORT); | |
45 PACKAGE C93005D_PK1 IS | |
46 | |
47 -- THIS TYPE OF TASK IS ALWAYS UNACTIVATED. | |
48 TASK TYPE UNACTIVATED IS | |
49 ENTRY E; | |
50 END UNACTIVATED; | |
51 | |
52 TYPE ACC_UNACTIVATED IS ACCESS UNACTIVATED; | |
53 | |
54 -- ******************************************* | |
55 -- DEFINITIONS FOR MUST NOT BE TERMINATED TASKS | |
56 -- ******************************************* | |
57 -- | |
58 -- THIS SET OF DECLARATIONS DEFINES A RECORD TYPE MNT (MUST NOT | |
59 -- TERMINATE). WHENEVER SUCH A RECORD IS DECLARED, A COUNT IS | |
60 -- INCREMENTED AND A TASK IS CREATED. THE TASK WILL DECREMENT THE | |
61 -- COUNT UNLESS IT IS INCORRECTLY AND PREMATURELY TERMINATED. | |
62 -- THE ROUTINE CHECK IS CALLED TO VERIFY WHETHER THE COUNT | |
63 -- HAS RETURNED TO 0 (ALL MNT TASKS GOT A CHANCE TO DO THEIR | |
64 -- DECREMENT). | |
65 | |
66 -- AN MNT TASK. SUCH TASKS MUST NOT BE TERMINATED | |
67 -- BY ANYONE BUT THEMSELVES. | |
68 -- | |
69 TASK TYPE MNT_TASK IS | |
70 END MNT_TASK; | |
71 | |
72 FUNCTION F RETURN INTEGER; | |
73 | |
74 -- THE RECORD THAT IS DECLARED TO HOLD AN MNT TASK | |
75 -- AND FORCE CALLING F BEFORE CREATING THE TASK. | |
76 -- F INCREMENTS THE COUNT, THE TASK DECREMENTS THE | |
77 -- COUNT. | |
78 -- | |
79 TYPE MNT IS | |
80 RECORD | |
81 DUMMY : INTEGER := F; | |
82 T : MNT_TASK; | |
83 END RECORD; | |
84 | |
85 PROCEDURE CHECK; | |
86 | |
87 | |
88 -- ******************************************* | |
89 -- END OF DEFINITIONS FOR MUST NOT BE TERMINATED TASKS | |
90 -- ******************************************* | |
91 | |
92 END C93005D_PK1; | |
93 | |
94 | |
95 PACKAGE BODY C93005D_PK1 IS | |
96 | |
97 -- THIS TASK IS CALLED IF AN UNACTIVATED TASK | |
98 -- IS EVER INCORRECTLY ACTIVATED. IT REPORTS FAILURE. | |
99 | |
100 TASK T IS | |
101 ENTRY E; | |
102 END; | |
103 | |
104 -- *********************************************** | |
105 -- START OF DEFINITIONS FOR MUST NOT TERMINATE TASKS | |
106 -- *********************************************** | |
107 | |
108 -- COUNT OF TASKS THAT MUST NOT BE TERMINATED AND | |
109 -- ARE STILL ACTIVE. | |
110 | |
111 MNT_COUNT : INTEGER := 0; | |
112 | |
113 -- TASK TO SYNCHRONIZE THE MNT_COUNT VARIABLE | |
114 | |
115 TASK MNT_COUNTER IS | |
116 ENTRY INCR; | |
117 ENTRY DECR; | |
118 END MNT_COUNTER; | |
119 | |
120 -- SYNCHRONIZING TASK | |
121 | |
122 TASK BODY MNT_COUNTER IS | |
123 BEGIN | |
124 LOOP | |
125 SELECT | |
126 ACCEPT INCR DO | |
127 MNT_COUNT := MNT_COUNT +1; | |
128 END INCR; | |
129 | |
130 OR ACCEPT DECR DO | |
131 MNT_COUNT := MNT_COUNT -1; | |
132 END DECR; | |
133 | |
134 OR TERMINATE; | |
135 | |
136 END SELECT; | |
137 END LOOP; | |
138 END MNT_COUNTER; | |
139 | |
140 -- INCREMENT THE MNT_COUNT WHEN A TASK IS CREATED | |
141 -- | |
142 FUNCTION F RETURN INTEGER IS | |
143 BEGIN | |
144 MNT_COUNTER.INCR; | |
145 RETURN 0; | |
146 END F; | |
147 | |
148 -- CHECK THAT THE MUST NOT BE TERMINATED TASKS ARE | |
149 -- NOT YET TERMINATED AND THAT THE SYNCRHONIZING TASK | |
150 -- ITSELF IS NOT TERMINATED. | |
151 -- | |
152 PROCEDURE CHECK IS | |
153 BEGIN | |
154 IF MNT_COUNT /= 0 OR MNT_COUNTER'TERMINATED THEN | |
155 FAILED ("SOME MUST-NOT-TERMINATE TASK WAS PREMATURELY " & | |
156 "TERMINATED"); | |
157 END IF; | |
158 -- RESET THE COUNT FOR THE NEXT SUBTEST: | |
159 MNT_COUNT := 0; | |
160 END CHECK; | |
161 | |
162 -- A MUST NOT BE TERMINATED TASK. DELAY LONG ENOUGH | |
163 -- TO BE THE LAST TASK OF A SCOPE TO TERMINATE. THEN | |
164 -- DECREMENT THE COUNTER. | |
165 -- | |
166 TASK BODY MNT_TASK IS | |
167 BEGIN | |
168 DELAY 5.0 * Impdef.One_Second; | |
169 MNT_COUNTER.DECR; | |
170 END MNT_TASK; | |
171 | |
172 -- *********************************************** | |
173 -- END OF DEFINITIONS FOR MUST NOT TERMINATE TASKS | |
174 -- *********************************************** | |
175 | |
176 TASK BODY T IS | |
177 BEGIN | |
178 LOOP | |
179 SELECT | |
180 ACCEPT E DO | |
181 FAILED ("SOME TYPE U TASK WAS ACTIVATED"); | |
182 END E; | |
183 | |
184 OR TERMINATE; | |
185 END SELECT; | |
186 END LOOP; | |
187 END T; | |
188 | |
189 -- TASKS OF TYPE UNACTIVATED MUST NEVER BE ACTIVATED. | |
190 -- | |
191 TASK BODY UNACTIVATED IS | |
192 BEGIN | |
193 T.E; | |
194 END UNACTIVATED; | |
195 END C93005D_PK1; | |
196 | |
197 WITH C93005D_PK1; USE C93005D_PK1; | |
198 PRAGMA ELABORATE (C93005D_PK1); | |
199 GENERIC | |
200 T1 : IN OUT UNACTIVATED; | |
201 PACKAGE C93005D_ENQUEUE IS | |
202 PROCEDURE REQUIRE_BODY; | |
203 END; | |
204 | |
205 with Impdef; | |
206 WITH REPORT; USE REPORT; | |
207 WITH SYSTEM; USE SYSTEM; | |
208 PRAGMA ELABORATE (REPORT); | |
209 PACKAGE BODY C93005D_ENQUEUE IS | |
210 | |
211 TASK T3 IS | |
212 END T3; | |
213 | |
214 TASK BODY T3 IS | |
215 BEGIN | |
216 T1.E; | |
217 FAILED ("ENQUEUED CALLER DID NOT GET EXCEPTION"); | |
218 EXCEPTION | |
219 WHEN TASKING_ERROR => NULL; | |
220 WHEN OTHERS => FAILED ("WRONG EXCEPTION RAISED"); | |
221 END T3; | |
222 | |
223 PROCEDURE REQUIRE_BODY IS | |
224 BEGIN | |
225 NULL; | |
226 END; | |
227 BEGIN -- T3 CALLS T1 HERE | |
228 DELAY 1.0 * Impdef.One_Second; -- ENSURE THAT T3 EXECUTES | |
229 END C93005D_ENQUEUE; | |
230 | |
231 WITH REPORT, C93005D_PK1, C93005D_ENQUEUE; | |
232 USE REPORT, C93005D_PK1; | |
233 WITH SYSTEM; USE SYSTEM; | |
234 PROCEDURE C93005D IS | |
235 | |
236 | |
237 BEGIN | |
238 | |
239 TEST("C93005D", "TEST EXCEPTIONS TERMINATE NOT YET ACTIVATED " & | |
240 "TASKS"); | |
241 | |
242 COMMENT("SUBTEST 2: TASKS IN DECL PART OF A BLOCK AND A PACKAGE " & | |
243 "SPEC"); | |
244 COMMENT(" THE TASKS DEPEND ON THE DECLARATIVE PART"); | |
245 COMMENT(" OTHER TASKS HAVE BEEN ENQUEUED ON THE TASKS' ENTRIES"); | |
246 B21: DECLARE | |
247 X : MNT; | |
248 BEGIN | |
249 B22: BEGIN | |
250 B23: DECLARE | |
251 TYPE ACC_MNT IS ACCESS MNT; | |
252 T1 : UNACTIVATED; | |
253 Y : ACC_MNT := NEW MNT; | |
254 | |
255 PACKAGE HAS_UNACTIVATED IS | |
256 T2 : UNACTIVATED; | |
257 Z : ACC_MNT := NEW MNT; | |
258 PACKAGE ENQUEUE1 IS NEW C93005D_ENQUEUE(T1); | |
259 PACKAGE ENQUEUE2 IS NEW C93005D_ENQUEUE(T2); | |
260 I : POSITIVE := IDENT_INT(0); -- RAISE | |
261 -- CONSTRAINT_ERROR EXCEPTION. | |
262 -- TERMINATES T1 AND T2 AND INDIRECTLY THE 2 T3'S | |
263 END HAS_UNACTIVATED; | |
264 USE HAS_UNACTIVATED; | |
265 BEGIN -- WOULD HAVE BEEN ACTIVATED HERE | |
266 IF EQUAL (I, I) THEN | |
267 FAILED ("EXCEPTION NOT RAISED"); | |
268 END IF; | |
269 EXCEPTION | |
270 WHEN OTHERS => | |
271 FAILED ("EXCEPTION RAISED IN WRONG SCOPE"); | |
272 END B23; | |
273 EXCEPTION | |
274 WHEN CONSTRAINT_ERROR => | |
275 COMMENT("SUBTEST 2 COMPLETED"); | |
276 WHEN OTHERS => | |
277 FAILED ("WRONG EXCEPTION RAISED IN B22"); | |
278 END B22; | |
279 END B21; | |
280 | |
281 CHECK; | |
282 | |
283 RESULT; | |
284 | |
285 EXCEPTION | |
286 WHEN OTHERS => | |
287 FAILED ("EXCEPTION NOT ABSORBED"); | |
288 RESULT; | |
289 END C93005D; |